From 1aa59cc205b40172b4a27067637f72a1ad29fc56 Mon Sep 17 00:00:00 2001 From: jgk Date: Fri, 7 May 2021 16:50:59 +0200 Subject: [PATCH] AI refactor --- src/Dodge/AIs.hs | 154 +------------------------ src/Dodge/Creature.hs | 36 +++--- src/Dodge/Creature/Action.hs | 141 +++++++++------------- src/Dodge/Creature/ActionRat.hs | 25 ++++ src/Dodge/Creature/ImpulseRat.hs | 48 ++++++-- src/Dodge/Creature/Picture.hs | 6 +- src/Dodge/Creature/Rationality.hs | 96 +++++++++++++-- src/Dodge/Creature/Rationality/Data.hs | 19 ++- src/Dodge/Creature/Stance/Data.hs | 2 +- src/Dodge/Creature/State.hs | 3 + src/Dodge/Creature/YourControl.hs | 66 +++-------- src/Dodge/Data.hs | 1 + src/Dodge/Default.hs | 1 + src/Dodge/Event/Keyboard.hs | 16 +-- src/Dodge/Floor.hs | 5 +- src/Geometry/Vector.hs | 16 ++- 16 files changed, 295 insertions(+), 340 deletions(-) create mode 100644 src/Dodge/Creature/ActionRat.hs diff --git a/src/Dodge/AIs.hs b/src/Dodge/AIs.hs index be42fee3a..f80f5e863 100644 --- a/src/Dodge/AIs.hs +++ b/src/Dodge/AIs.hs @@ -1,6 +1,5 @@ module Dodge.AIs - ( chaseAI - , basicShooterAI + ( basicShooterAI , twitchMissAI , launcherAI , chargeAI @@ -62,70 +61,6 @@ replaceImpulse newActions = over (crState . goals) (\((_:as):ass) -> (newActions addImpulse :: [Impulse] -> Creature -> Creature addImpulse newActions = over (crState . goals) (\(as:ass) -> (newActions++as):ass) -chaseAI = expandToAI chaseAI' - -chaseAI' :: World -> StdGen -> Creature -> (World -> World, StdGen, Creature) -chaseAI' w g' cr = - let cid = _crID cr - cpos = _crPos cr - hitCr i = over (creatures . ix i . crState . crDamage) addDam - . soundOnce (fromIntegral hitSound) - addDam dams = (( Blunt 100 cpos ypos ypos ) : dams ) - ypos = _crPos $ you w - combinedRad = _crRad cr + _crRad (you w) - (a,g) = randomR (-0.2,0.2) g' - (wtime,g1) = randomR (15,25) g' - randomTurn = over crDir (+a) - isCrowded = (length $ IM.elems $ IM.filter isCloseFaction (_creatures w)) > 2 - isCloseFaction cr' = _faction (_crState cr') == _faction (_crState cr) - && dist cpos (_crPos cr') < 25 - in case head $ _goals $ _crState cr of - [] -> (id, g', replaceGoal [] cr) - (Wait:_) - | dist cpos ypos < 900 && hasLOS cpos ypos w - -> (id, g', addGoal [[WaitFor wtime,MoveTo ypos]] cr) - | dist cpos ypos < 900 && hasLOSIndirect cpos ypos w - -> (id, g', addGoal [[WaitFor wtime,PathTo ypos]] cr) - | otherwise -> (id, g', cr) - (WaitFor x:gls) - | x == 0 -> (id, g', replaceImpulse [] cr) - | hasLOS cpos ypos w - -> (id, g', replaceImpulse [WaitFor (x-1)] $ crTurnTowardSpeed 0.05 ypos cr) - | otherwise -> (id, g', replaceImpulse [WaitFor (x-1)] cr ) - (MoveTo p:gls) - | dist ypos cpos < combinedRad + 5 && abs ((_crDir cr) - argV (ypos -.- cpos)) < pi/4 - -> ( hitCr 0 , g' - , replaceImpulse [MeleeAttack 5] - $ over crPos (+.+ (12 *.* errorNormalizeVAI (ypos -.- cpos))) cr - ) - | hasLOS cpos ypos w -> - ( id , g , replaceImpulse [MoveTo ypos] - $ crMvForward 2.5 $ randomTurn $ crTurnTowardSpeed 0.05 p cr) - | dist p cpos < 10 -> ( id, g' , replaceImpulse [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( id ,g' , crTurnTowardSpeed 0.05 p cr) - | otherwise -> ( id, g' , crMvForward 2.5 $ crTurnTowardSpeed 0.05 p cr) - (MoveToFor p x:gls) - | hasLOS cpos ypos w -> - ( id , g , replaceImpulse [MoveTo ypos] - $ crMvForward 2.5 $ randomTurn $ crTurnTowardSpeed 0.05 p cr - ) - | dist p cpos < 10 -> ( id , g , replaceImpulse [] cr) - | x == 0 -> ( id , g , replaceImpulse [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 -> - ( id , g , replaceImpulse [MoveToFor p (max 0 (x-1))] $ crTurnTowardSpeed 0.05 p cr) - | otherwise -> - ( id , g , replaceImpulse [MoveToFor p (max 0 (x-1))] - $ crMvForward 2.5 $ crTurnTowardSpeed 0.05 p cr) - (PathTo p:_) - | dist p cpos < 10 -> ( id , g , replaceImpulse [] cr) - | hasLOS cpos p w -> ( id , g , addImpulse [MoveToFor p 10] cr) - | otherwise -> case pointTowardsImpulse cpos p w of - Just q -> ( id , g , addImpulse [MoveToFor q 10] cr) - _ -> ( id , g , replaceImpulse [] cr) - (MeleeAttack x:_) - | x == 0 -> ( id , g , replaceImpulse [WaitFor wtime] cr ) - | otherwise -> ( id , g , replaceImpulse [MeleeAttack (x-1)] cr ) factionIs :: Faction -> Creature -> Bool @@ -318,88 +253,6 @@ placeCrFaction cr fact p op rot w = over creatures addCr w ) crs - - ----- meleeAI' :: Int -> World -> World ----- meleeAI' cid w = let cr = _creatures w IM.! cid ----- cpos = _crPos cr ----- damageYou = over (creatures . ix 0 . crHP) (\hp -> hp - 10) . soundOnce hitSound ----- ypos = _crPos $ you w ----- combinedRad = _crRad cr + _crRad (you w) ----- (a,g) = randomR (-0.2,0.2) $ _randGen w ----- (wtime,g1) = randomR (15,25) $ _randGen w ----- randomTurn = set randGen g . over (creatures . ix cid . crDir) (+a) ----- randomTurn2 = set randGen g . over (creatures . ix cid . crDir) (+(signum a)) ----- isCrowded = (length $ IM.elems $ IM.filter isCloseFaction (_creatures w)) > 2 ----- isCloseFaction cr' = _faction (_crState cr') == ChaseCritters ----- && dist cpos (_crPos cr') < 25 ----- replaceGoal newImpulses = over (creatures . ix cid . crState . goals) ----- (\gs -> newImpulses ++ tail gs) ----- addGoal newImpulses = over (creatures . ix cid . crState . goals) ----- (\gs -> newImpulses ++ gs) ----- replaceImpulse newActions = over (creatures . ix cid . crState . goals) ----- (\((_:as):ass) -> (newActions ++ as):ass) ----- addImpulse newActions = over (creatures . ix cid . crState . goals) ----- (\(as:ass) -> (newActions++as):ass) ----- in if _crHP cr <= 0 then killCr cid w else ----- case head $ _goals $ _crState cr of ----- [] | canSee cid (_yourID w) w ----- -> replaceGoal [[MoveToFor ypos 10]] w ----- | canSeeIndirect cid (_yourID w) w ----- -> addGoal [[PathTo ypos]] w ----- | otherwise -> replaceGoal [] w ----- (WaitFor x:gls)| x == 0 -> replaceImpulse [] w ----- | canSee cid (_yourID w) w ----- -> turnTowardSpeed 0.05 ypos cid ----- $ replaceImpulse [WaitFor (x-1)] w ----- | otherwise -> replaceImpulse [WaitFor (x-1)] w ----- (MoveToFor p x:gls) ----- | dist ypos cpos < combinedRad + 5 ----- && abs ((_crDir cr) - argV (ypos -.- cpos)) < pi/4 -- same error as above ----- -- && x == 0 ----- -> over (creatures . ix cid . crPos) ----- (+.+ (12 *.* errorNormalizeVAI (ypos -.- cpos))) ----- $ replaceImpulse [MeleeAttack 5] ----- $ damageYou ----- w ----- | x == 0 && isCrowded -> replaceImpulse [] $ randomTurn2 w ----- | canSee cid (_yourID w) w -> replaceGoal [[MoveToFor ypos (max 0 (x-1))]] ----- $ mvForward 2.5 cid $ randomTurn $ turnTowardSpeed 0.05 p cid w ----- | dist p cpos < 10 -> replaceImpulse [] w ----- | x == 0 -> replaceImpulse [] w ----- -- | not (canSeePoint cid p w) -> replaceImpulse [PathTo p] w ----- -- | not (canSeePoint cid p w) -> replaceImpulse [] w ----- | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 ----- -> replaceImpulse [MoveToFor p (max 0 (x-1))] $ turnTowardSpeed 0.05 p cid w ----- | otherwise -> replaceImpulse [MoveToFor p (max 0 (x-1))] ----- $ mvForward 2.5 cid $ turnTowardSpeed 0.05 p cid w ----- (PathTo p:_) ----- | dist p cpos < 10 -> replaceImpulse [] w ----- | canSeePoint cid p w -> addImpulse [MoveToFor p 10] w ----- | otherwise -> ----- case pointTowardsImpulse' cpos p w of ----- Right q -> addImpulse [MoveToFor q 10] ----- -- $ drawCircleAtForCol q 10 magenta ----- -- $ drawLineForCol ((cpos : (concat $ maybeToList $ makePathBetweenPs ----- -- cpos p w)) ++ [p]) 50 red ----- w ----- --Left s -> error s ----- _ -> replaceImpulse [] w ----- (MeleeAttack x:_) ----- | x == 0 -> replaceImpulse [WaitFor wtime] w ----- | otherwise -> replaceImpulse [MeleeAttack (x-1)] w ----- (TrackYou:_) -> addGoal [[WaitFor wtime,PathTo ypos]] $ set randGen g1 w ----- (InitTrackYou:_)| canSeeIndirect cid (_yourID w) w -> replaceGoal [[TrackYou]] w ----- | otherwise -> w ----- (Guard p p':_) | canSeeIndirect cid (_yourID w) w ----- -> addGoal [[WaitFor wtime,PathTo ypos]] $ set randGen g1 w ----- | dist cpos p > 10 ----- -> addGoal [[PathTo p]] w ----- | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 ----- -> turnTowardSpeed 0.05 p' cid w ----- | otherwise -> w ----- (InitGuard :_) -> replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] w - -- be aware that the crit can be removed -- don't just refer to its id in the -- world->world part miniAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) @@ -1481,10 +1334,7 @@ basicShooterAI w (f,g) cr = = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) addImpulse newActions = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) --- autoFireTweak p | _wpIsAuto wp = Just --- | otherwise = replaceGoal [[AimAt p (_itUseRate wp * 2)]] - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of + in case head $ _goals $ _crState cr of [] | canSeeFire cpos ypos w -> ( ( f , g1 ) , replaceGoal [[AimAt ypos aimtime]] cr ) diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 66c0e66cc..96a76ad6c 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -6,6 +6,9 @@ module Dodge.Creature import Dodge.Creature.Stance.Data import Dodge.Creature.State.Data import Dodge.Creature.Impulse.Data +import Dodge.Creature.ImpulseRat +import Dodge.Creature.ActionRat +import Dodge.Creature.Rationality.Data import Dodge.Data import Dodge.AIs import Dodge.Default @@ -18,6 +21,7 @@ import Dodge.Creature.Inanimate import Dodge.Creature.State import Dodge.Creature.Picture import Dodge.Creature.Rationality +import Dodge.Creature.ChooseTarget import Dodge.Item import Dodge.Picture.Layer import Dodge.Creature.Picture @@ -53,7 +57,7 @@ spawnerCrit = defaultCreature } smallChaseCrit :: Creature smallChaseCrit = defaultCreature - { _crUpdate = stateUpdate chaseAI + { _crUpdate = stateUpdate $ meleeCooldown $ impulsiveAI $ chaseTarget targetYouLOS , _crHP = 1 , _crRad = 4 , _crPict = basicCrPict green @@ -66,18 +70,7 @@ smallChaseCrit = defaultCreature } chaseCrit :: Creature chaseCrit = defaultCreature - { _crUpdate = stateUpdate $ impulsiveAI $ applyBasicImpulse - , _crHP = 300 - , _crPict = basicCrPict green - , _crState = defaultState - {_goals = [[Wait]] - ,_faction = ChaseCritters - } - , _crInv = IM.empty - } -chaseCrit' :: Creature -chaseCrit' = defaultCreature - { _crUpdate = stateUpdate chaseAI + { _crUpdate = stateUpdate $ meleeCooldown $ impulsiveAI $ chaseTarget targetYouLOS , _crHP = 300 , _crPict = basicCrPict green , _crState = defaultState @@ -85,10 +78,11 @@ chaseCrit' = defaultCreature ,_faction = ChaseCritters } , _crInv = IM.empty + , _crMeleeCooldown = Just 0 } armourChaseCrit :: Creature armourChaseCrit = defaultCreature - { _crUpdate = stateUpdate chaseAI + { _crUpdate = stateUpdate $ meleeCooldown $ impulsiveAI $ chaseTarget targetYouLOS , _crHP = 300 , _crPict = basicCrPict green , _crState = defaultState {_goals = [[Wait]]} @@ -97,6 +91,20 @@ armourChaseCrit = defaultCreature ,(1,medkit 200) ] } +miniGunCrit' :: Creature +miniGunCrit' = defaultCreature + { _crPict = basicCrPict red + , _crUpdate = stateUpdate $ impulsiveAI $ actionUpdateAI $ shootAtTarget targetYouLOS + , _crInv = IM.fromList [(0,miniGun)] + , _crInvSel = 0 + , _crRad = 10 + , _crState = defaultState + , _crHP = 500 + , _crRationality = ActionRat + { _crImpulse = [] + , _crAction = [AimAtCloseSlow 0 (0,0) 0.05 0.2 (pi/4) ] + } + } miniGunCrit :: Creature miniGunCrit = defaultCreature { _crPict = basicCrPict red diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index 54dbc4621..127ebf879 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -30,20 +30,11 @@ import System.Random import qualified Data.IntMap.Strict as IM import qualified Data.Map as M -moveForwardSpeed - :: Float -- ^ Speed - -> Int -- ^ Creature id - -> World - -> World -moveForwardSpeed x n w = over (creatures . ix n . crPos) (+.+ p) w - where - p = (*.*) x $ unitVectorAtAngle $ _crDir $ _creatures w IM.! n - crStrafeLeft :: Float -- ^ Speed -> Creature -> Creature -crStrafeLeft speed cr = stepForward s2 $ over crPos (+.+ p) cr +crStrafeLeft speed cr = advanceStepCounter s2 $ over crPos (+.+ p) cr where p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr + pi/2) equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr @@ -53,42 +44,12 @@ crStrafeRight :: Float -- ^ Speed -> Creature -> Creature -crStrafeRight speed cr = stepForward s2 $ over crPos (+.+ p) cr +crStrafeRight speed cr = advanceStepCounter s2 $ over crPos (+.+ p) cr where p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr - pi/2) equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr s2 = (speed * equipFactor) -crMvForward - :: Float -- ^ Speed - -> Creature - -> Creature -crMvForward speed cr = over crPos (+.+ p) cr - where - p = (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir cr - equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr - -crMvBy - :: Point2 -- ^ Movement translation vector - -> Creature - -> Creature -crMvBy p' cr = stepForward (magV p) $ over crPos (+.+ p) cr - where - p = (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p' - equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr - aimingFactor | (_posture $ _crStance cr) == Aiming - = fromMaybe 1 $ it ^? itAimingSpeed - | otherwise = 1 - it = _crInv cr IM.! _crInvSel cr - -stepForward - :: Float -- ^ Speed - -> Creature - -> Creature -stepForward speed cr = over (crStance . carriage) f cr - where - f (w@Walking {}) = w {_stepToAdd = ceiling speed} - f s = s turnTo @@ -233,32 +194,7 @@ turnToward p n w where cr = _creatures w IM.! n dirToTarget = argV (p -.- _crPos cr) - -{- Move a creature forward in the direction it is facing. -} -moveForward - :: Int -- ^ Creature id - -> World - -> World -moveForward n w = over (creatures . ix n . crPos) (+.+ p) w - where - p = unitVectorAtAngle $ _crDir $ _creatures w IM.! n - -{- Move a creature forward, faster if it is facing a target point -} -moveToward - :: Point2 -- ^ Target point - -> Int -- ^ Creature id - -> World - -> World -moveToward p n w - | angle < 10 = moveForwardSpeed 0.1 n w - | angle < 20 = moveForwardSpeed 0.02 n w - | angle < 40 = moveForwardSpeed 0.01 n w - | otherwise = w - where - angle = errorAngleVV 5 (p -.- curPos) (unitVectorAtAngle (_crDir (_creatures w IM.! n))) - curPos = _crPos (_creatures w IM.! n) - -{- Translate a creature. -} +{- | Translate a creature. -} moveBy :: Int -- ^ Creature id -> Point2 -- ^ Translation @@ -280,7 +216,7 @@ reloadWeapon cid w = $ set ( itRef . wpReloadState) rT w _ -> Nothing -{- Start reloading if clip is empty. -} +{- | Start reloading if clip is empty. -} crAutoReload :: Creature -> Creature crAutoReload cr = case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of Just 0 -> cr & crInv . ix (_crInvSel cr) . wpReloadState %~ (`fromMaybe` reloadT) @@ -290,7 +226,7 @@ crAutoReload cr = case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of reloadT = cr ^? crInv . ix (_crInvSel cr) . wpReloadTime maxA = cr ^? crInv . ix (_crInvSel cr) . wpMaxAmmo -{- Teleport a creature to the mouse position -} +{- | Teleport a creature to the mouse position -} blinkAction :: Int -- ^ Creature id -> World @@ -334,10 +270,7 @@ turnBy -> World -> World turnBy a n = over (creatures . ix n . crDir) (+ a) - -{- -Get your creature to drop the item under the cursor. --} +{- | Get your creature to drop the item under the cursor. -} youDropItem :: World -> World youDropItem w = case yourItem w of NoItem -> w @@ -345,8 +278,7 @@ youDropItem w = case yourItem w of . copyItemToFloor (you w) (_crInvSel $ you w) $ soundOnce putDownSound w - -{- Copy an inventory item to the floor. -} +{- | Copy an inventory item to the floor. -} copyItemToFloor :: Creature -> Int -- ^ Inventory position @@ -354,9 +286,7 @@ copyItemToFloor -> World copyItemToFloor cr i w = case _crInv cr IM.! i of NoItem -> w - it -> over floorItems (IM.insert flid theflit) - . updateLocation - $ set randGen g w + it -> over floorItems (IM.insert flid theflit) . updateLocation $ set randGen g w where (rot, g) = randomR (-pi,pi) $ _randGen w offset = (_crRad cr + 2) *.* unitVectorAtAngle rot @@ -370,16 +300,19 @@ copyItemToFloor cr i w = case _crInv cr IM.! i of ,_flItRot = rot ,_flItID = flid } - -{- Pick up a specific item. -} -pickUpItem :: FloorItem -> World -> World -pickUpItem flit w = case maybeInvSlot of +{- | Pick up a specific item. -} +pickUpItem + :: Int -- ^ Creature id + -> FloorItem + -> World + -> World +pickUpItem cid flit w = case maybeInvSlot of Nothing -> w Just i -> w & soundOnce pickUpSound & updateItLocation i & floorItems %~ IM.delete (_flItID flit) - & creatures . ix 0 . crInv . ix i %~ addItem it + & creatures . ix cid . crInv . ix i %~ addItem it where it = _flIt flit maybeInvSlot = checkInvSlotsYou it w @@ -387,12 +320,48 @@ pickUpItem flit w = case maybeInvSlot of Nothing -> w' Just j -> w' & itemPositions . ix j .~ InInv 0 invid -{- | A creature attempts to move under its own steam. +{- | 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. -} -creatureMove :: Point2 -> Creature -> Creature -creatureMove p = crPos %~ (+.+ p) +crMvBy + :: Point2 -- ^ Movement translation vector + -> Creature + -> Creature +crMvBy p' cr = advanceStepCounter (magV p) $ over crPos (+.+ p) cr + where + p = (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p' + equipFactor = 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 cr = crMvBy (speed,0) cr + + +advanceStepCounter + :: Float -- ^ Speed + -> Creature + -> Creature +advanceStepCounter speed cr = over (crStance . carriage) f cr + where + f (w@Walking {}) = w {_stepToAdd = ceiling speed} + f s = s creatureTurn :: Float -> Creature -> Creature creatureTurn a = crDir +~ a +creatureTurnToward :: Point2 -> Float -> Creature -> Creature +creatureTurnToward p turnSpeed cr + | vToTarg == (0,0) = cr -- this should deal with the angleVV error + | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed + = cr & crDir .~ dirToTarget + | isLeftOfA dirToTarget (_crDir cr) = cr & crDir +~ turnSpeed + | otherwise = cr & crDir -~ turnSpeed + where + vToTarg = p -.- _crPos cr + dirToTarget = argV vToTarg diff --git a/src/Dodge/Creature/ActionRat.hs b/src/Dodge/Creature/ActionRat.hs new file mode 100644 index 000000000..320e859d7 --- /dev/null +++ b/src/Dodge/Creature/ActionRat.hs @@ -0,0 +1,25 @@ +module Dodge.Creature.ActionRat + where +import Dodge.Data +import Dodge.Base.Collide +import Dodge.Creature.ChooseTarget +import Dodge.Creature.Rationality.Data +import Geometry + +import Data.List +import Control.Lens + +{- | Action update for a simple shooting creature -} +shootAtTarget + :: (Creature -> World -> Maybe Creature) -- ^ Function for determining target + -> World + -> Creature + -> Creature +shootAtTarget targFunc w cr = case targFunc cr w of + Nothing -> cr + Just crTarg -> cr & crRationality . crAction %~ shootAtTarg w cr crTarg + +shootAtTarg :: World -> Creature -> Creature -> [Action] -> [Action] +shootAtTarg w cr tcr as + | canSee (_crID cr) (_crID tcr) w = nub (ShootTillEmpty : as) + | otherwise = as diff --git a/src/Dodge/Creature/ImpulseRat.hs b/src/Dodge/Creature/ImpulseRat.hs index a616df59f..52e53883e 100644 --- a/src/Dodge/Creature/ImpulseRat.hs +++ b/src/Dodge/Creature/ImpulseRat.hs @@ -5,21 +5,55 @@ import Dodge.Creature.ChooseTarget import Dodge.Creature.Rationality.Data import Geometry -chaseImpulse' +import Control.Lens + +chaseTarget :: (Creature -> World -> Maybe Creature) -- ^ Function for determining target - -> Creature -> World - -> [Impulse] -chaseImpulse' targFunc cr w = case targFunc cr w of - Nothing -> [] - Just crTarg -> chaseTarg cr crTarg + -> Creature + -> Creature +chaseTarget targFunc w cr = case targFunc cr w of + Nothing -> cr + Just crTarg -> cr & crRationality . crImpulse .~ chaseTarg cr crTarg chaseTarg :: Creature -> Creature -> [Impulse] chaseTarg cr crT | dist tpos cpos < combinedRad + 5 && abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4 + && _crMeleeCooldown cr == Just 0 = [Melee (_crID crT)] - | otherwise = [MoveForward 3 , TurnToward 0.05 tpos] + | dist tpos cpos < combinedRad + 5 + && abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4 + = [ TurnToward tpos 0.05 ] + | abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4 + = [MoveForward 2.5 , TurnToward tpos 0.2, RandomTurn 0.2 ] + | otherwise = [MoveForward 2.5 , TurnToward tpos 0.05, RandomTurn 0.2 ] + where + cpos = _crPos cr + tpos = _crPos crT + combinedRad = _crRad cr + _crRad crT + +impulseShootAtTarget + :: (Creature -> World -> Maybe Creature) -- ^ Function for determining target + -> World + -> Creature + -> Creature +impulseShootAtTarget targFunc w cr = case targFunc cr w of + Nothing -> cr + Just crTarg -> cr & crRationality . crImpulse .~ impulseShootAtTarg cr crTarg + +impulseShootAtTarg :: Creature -> Creature -> [Impulse] +impulseShootAtTarg cr crT + | dist tpos cpos < combinedRad + 5 + && abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4 + && _crMeleeCooldown cr == Just 0 + = [Melee (_crID crT)] + | dist tpos cpos < combinedRad + 5 + && abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4 + = [ TurnToward tpos 0.05 ] + | abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4 + = [MoveForward 2.5 , TurnToward tpos 0.2, RandomTurn 0.2 ] + | otherwise = [MoveForward 2.5 , TurnToward tpos 0.05, RandomTurn 0.2 ] where cpos = _crPos cr tpos = _crPos crT diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index 2b41854a7..8b9b36c5e 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -22,8 +22,9 @@ basicCrPict col cr = pictures [ onLayer CrLayer . piercingMod $ bluntScale naked where cdir = _crDir cr naked + | strikeMelee = color white $ circleSolid $ _crRad cr | pdam > 200 = color red $ circleSolid $ _crRad cr - | pdam > 100 = color white $ circleSolid $ _crRad cr + | pdam > 99 = color white $ circleSolid $ _crRad cr | otherwise = pictures [color col' $ circleSolid $ _crRad cr, circLine $ _crRad cr] pastDams = _crPastDamage $ _crState cr pdam = sum $ concatMap (map _dmAmount) $ pastDams @@ -41,6 +42,9 @@ basicCrPict col cr = pictures [ onLayer CrLayer . piercingMod $ bluntScale naked piercingMod = case fmap argV piercingDam of Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a) _ -> id + strikeMelee = case _crMeleeCooldown cr of + Nothing -> False + Just x -> x > 5 drawEquipment :: Creature diff --git a/src/Dodge/Creature/Rationality.hs b/src/Dodge/Creature/Rationality.hs index 5bd931a62..49f9ab27e 100644 --- a/src/Dodge/Creature/Rationality.hs +++ b/src/Dodge/Creature/Rationality.hs @@ -1,33 +1,105 @@ module Dodge.Creature.Rationality where import Dodge.Data +import Dodge.Base.Collide import Dodge.Creature.Rationality.Data import Dodge.Creature.Action import Dodge.Creature.Action.UseItem +import Dodge.Creature.State.Data +import Dodge.SoundLogic +import Geometry +import Data.Maybe +import qualified Data.IntMap.Strict as IM import System.Random import Control.Lens impulsiveAI - :: (Impulse -> World -> Creature -> (World -> World, Creature)) - -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -impulsiveAI impulseFunc w (f,g) cr - = (\(f''' ,cr) -> ((f''',g),Just cr)) - $ foldr - (\imp (f' , cr') -> let (f'', cr'') = impulseFunc imp w cr' in (f'' . f', cr'')) - (id, cr) - (_crImpulse $ _crRationality cr) + :: (World -> Creature -> Creature) -- ^ Internal AI update, should determine impulses + -> World + -> (World -> World,StdGen) + -> Creature + -> ((World -> World,StdGen), Maybe Creature) +impulsiveAI impF w (f,g) = followImpulses w (f,g) . impF w -applyBasicImpulse +followImpulses + :: World + -> (World -> World,StdGen) + -> Creature + -> ((World -> World,StdGen), Maybe Creature) +followImpulses w (f,g) cr + = (\(f''' ,cr) -> ((f''',g'),Just cr)) + $ foldr + (\imp (f' , cr') -> let (f'', cr'') = followImpulse imp w cr' in (f'' . f', cr'')) + (f, cr) + (_crImpulse $ _crRationality cr) + where + g' = snd $ next g + +followImpulse :: Impulse -> World -> Creature -> (World -> World , Creature) -applyBasicImpulse imp w cr = case imp of - Move p -> (id, creatureMove p cr) +followImpulse imp w cr = 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) UseItem -> (crUseItem cr, cr) SwitchToItem i -> (id, cr & crInvSel .~ i) - _ -> (id, cr) + Melee crID -> + (hitCr crID + , crMvBy (10 *.* normalizeV (posFromID crID -.- cpos)) $ cr & crMeleeCooldown ?~ 20) -- randomise cooldown? + RandomTurn a -> (id, creatureTurn (rr a) cr) + _ -> (id , cr) DropItem -> undefined + where + cpos = _crPos 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 (fromIntegral hitSound) + addDam i dams = (( Blunt 100 cpos (posFromID i) (posFromID i) ) : dams ) + +actionUpdateAI + :: (World -> Creature -> Creature) -- ^ the function updating the actions + -> World + -> Creature + -> Creature +actionUpdateAI actF w c = performActions w $ actF w c + +performActions :: World -> Creature -> Creature +performActions w cr = cr + & crRationality . crImpulse .~ concat iss + & crRationality . crAction .~ catMaybes mayas + where + (iss, mayas) = unzip $ map (performAction cr w) $ cr ^. crRationality . crAction + +{- | Performing an action means that a creature has some impulses for a frame, and + updates or deletes the action itself. -} +performAction + :: Creature + -> World + -> Action + -> ( [Impulse] , Maybe Action ) +performAction cr w ac = case ac of + ShootTillEmpty -> case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of + Just x | x > 0 -> ( [UseItem] , Just ShootTillEmpty ) + _ -> ( [] , Nothing ) + AimAtCloseSlow tcid p speed slowSpeed a + | canSee (_crID cr) tcid w && abs (normalizeAngle $ cdir - argV (tpos -.- cpos)) < a + -> ([TurnToward tpos slowSpeed] , Just $ AimAtCloseSlow tcid tpos speed slowSpeed a) + | canSee (_crID cr) tcid w + -> ([TurnToward tpos speed] , Just $ AimAtCloseSlow tcid tpos speed slowSpeed a) + | abs (normalizeAngle (cdir - (argV (p -.- cpos)))) < a + -> ([TurnToward p slowSpeed] , Just $ AimAtCloseSlow tcid p speed slowSpeed a) + | otherwise -> ([TurnToward p speed] , Just $ AimAtCloseSlow tcid p speed slowSpeed a) + where + tpos = _crPos (_creatures w IM.! tcid) + ImpulsesList (xs:xss) -> (xs, Just $ ImpulsesList xss) + ImpulsesList _ -> ([], Nothing) + where + cpos = _crPos cr + cdir = _crDir cr diff --git a/src/Dodge/Creature/Rationality/Data.hs b/src/Dodge/Creature/Rationality/Data.hs index ba2896128..e21d585e3 100644 --- a/src/Dodge/Creature/Rationality/Data.hs +++ b/src/Dodge/Creature/Rationality/Data.hs @@ -12,18 +12,19 @@ data Rationality {_crImpulse :: [Impulse] } | ActionRat {_crImpulse :: [Impulse] - ,_crAction :: Action + ,_crAction :: [Action] } | StrategyRat {_crImpulse :: [Impulse] - ,_crAction :: Action + ,_crAction :: [Action] ,_crStrategy :: Strategy } data Impulse = Move Point2 | MoveForward Float | Turn Float - | TurnToward Float Point2 + | RandomTurn Float + | TurnToward Point2 Float | UseItem | SwitchToItem Int | DropItem @@ -33,9 +34,18 @@ data Impulse | UseIntrinsicAbility | Melee Int | ChangePosture Posture + deriving (Eq,Ord,Show) data Action = Attack Int + | AimAtCloseSlow + {_targetID :: Int + ,_targetSeenAt :: Point2 + ,_aimSpeed :: Float + ,_slowAimSpeed :: Float + ,_slowAimAngle :: Float + } + | MeleeAttack Point2 Int | PathTo Point2 | FleeFrom Int | HealSelf @@ -44,6 +54,9 @@ data Action | SearchFor Int | Search | PickupItem Int + | ShootTillEmpty + | ImpulsesList [[Impulse]] + deriving (Eq,Ord,Show) data Strategy = Flank Int diff --git a/src/Dodge/Creature/Stance/Data.hs b/src/Dodge/Creature/Stance/Data.hs index c90b55a17..06063300f 100644 --- a/src/Dodge/Creature/Stance/Data.hs +++ b/src/Dodge/Creature/Stance/Data.hs @@ -18,7 +18,7 @@ data Carriage | Boosting Point2 deriving (Eq,Show) data Posture = Aiming | AtEase - deriving (Eq,Show) + deriving (Eq,Ord,Show) makeLenses ''Stance makeLenses ''Carriage diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index 5d3ad56f7..1def08749 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -36,6 +36,9 @@ import Control.Concurrent type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +meleeCooldown :: CRUpdate -> CRUpdate +meleeCooldown u w (f,g) cr = u w (f,g) $ cr & crMeleeCooldown . _Just %~ (max 0 . (\x -> x - 1)) + -- | The movement is updated before the ai in order to correctly set the oldpos. -- the whole of this update cycle could do with a rethink, it is becoming -- convoluted diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs index 178bf1fe0..4798f5e1d 100644 --- a/src/Dodge/Creature/YourControl.hs +++ b/src/Dodge/Creature/YourControl.hs @@ -20,62 +20,32 @@ import System.Random yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) yourControl w (f,g) cr = ( (updateUsingInput . f, g) - , Just . crAutoReload . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr + , Just . crAutoReload . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed 0 cr ) where - strafeSpeed = _varMovementSpeedModifier w * equipFactor * fromMaybe 1 (yourItem w ^? itAimingSpeed) speed = _varMovementSpeedModifier w * equipFactor equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! 0 {- Turns key presses into creature movement. -} -wasdWithAiming :: World -> Float -> Float -> Int -> Creature -> Creature -wasdWithAiming w speed aimSpeed i cr - | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving && isAiming - && diffAngles mouseDir (argV mov) < pi/2 - -- = over crPos (+.+ (speed *.* mov)) - = over crPos (+.+ (speed *.* unitVectorAtAngle mouseDir)) - . set crDir mouseDir - $ set (crStance . carriage) (Boosting mov) - cr - | any (\it -> it ^? itIdentity == Just JetPack) (_crInv cr) && isMoving && isAiming - = set crDir mouseDir - $ set (crStance . carriage) Floating - cr - | any (\it -> it ^? itIdentity == Just JetPack) (_crInv cr) && isMoving - = over crPos (+.+ (speed *.* mov)) - . over crDir (flip fromMaybe dir) - $ set (crStance . carriage) (Boosting mov) - cr - | any (\it -> it ^? itIdentity == Just JetPack) (_crInv cr) && isAiming - = set (crStance . carriage) Floating - $ set crDir mouseDir - cr - | any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr - = set (crStance . carriage) Floating - cr +wasdWithAiming :: World -> Float -> Int -> Creature -> Creature +wasdWithAiming w speed i cr | isAiming - = stepForward aimSpeed - $ over crPos (+.+ (aimSpeed *.* mov)) - $ set crDir mouseDir - $ set (crStance . carriage) (Walking 0 0) + = set crDir mouseDir + $ crMvBy (speed *.* mov) cr | isMoving - = stepForward speed - $ over crPos (+.+ (speed *.* mov)) - $ over crDir (`fromMaybe` dir) - $ set (crStance . carriage) (Walking 0 0) + = crMvForward speed -- controls the base speed + $ over crDir (`fromMaybe` dir) cr - | otherwise - = over crDir (`fromMaybe` dir) - $ set (crStance . carriage) Standing - cr + | otherwise = cr where (mov',dir') = wasdComp (view keys w) w - (mov,dir) = (rotateV (_cameraRot w) mov',fmap (_cameraRot w +) dir') - isMoving = mov' /= (0,0) + dir = fmap (_cameraRot w +) dir' + mov = rotateV (negate $ _crDir cr) mov' isAiming = _posture (_crStance cr) == Aiming + isMoving = mov' /= (0,0) mouseDir = case w ^? creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) . itAttachment of Just (Just ItScope{_scopePos = p}) -> normalizeAngle $ argV @@ -97,12 +67,12 @@ wasdComp ks w = f $ foldr ( (+.+) . wasdM w ) (0,0) ks where f (0,0) = ((0,0), Nothing) f p = (errorNormalizeV 46 p, Just $ argV p) +{- | Set posture according to mouse presses. -} mouseActionsCr :: S.Set SDL.MouseButton -> Creature -> Creature -mouseActionsCr keys cr - | rbPressed - = set ( crStance . posture) Aiming cr - | otherwise - = set ( crStance . posture) AtEase cr - where lbPressed = SDL.ButtonLeft `S.member` keys - rbPressed = SDL.ButtonRight `S.member` keys +mouseActionsCr keys + | rbPressed = crStance . posture .~ Aiming + | otherwise = crStance . posture .~ AtEase + where + lbPressed = SDL.ButtonLeft `S.member` keys + rbPressed = SDL.ButtonRight `S.member` keys diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index b7905df50..b6baefcd4 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -151,6 +151,7 @@ data Creature = Creature , _crApplyDamage :: [DamageType] -> Creature -> (World -> World,Creature) , _crStance :: Stance , _crRationality :: Rationality + , _crMeleeCooldown :: Maybe Int } data WorldState = DoorNumOpen Int diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 68e624cf9..4750f995f 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -91,6 +91,7 @@ defaultCreature = Creature , _crApplyDamage = defaultApplyDamage , _crStance = Stance {_carriage=Walking 0 0,_posture=AtEase} , _crRationality = ImpulseRat [] + , _crMeleeCooldown = Nothing } defaultState = CrSt { _goals = [] diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index df59ab36f..2e188ed7a 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -34,10 +34,7 @@ see 'handlePressedKeyInGame'. handleKeyboardEvent :: KeyboardEventData -> World -> Maybe World handleKeyboardEvent kev w = case keyboardEventKeyMotion kev of Released -> Just $ w & keys %~ S.delete kcode - Pressed -> handlePressedKey - (keyboardEventRepeat kev) - kcode - (w & keys %~ S.insert kcode) + Pressed -> handlePressedKey (keyboardEventRepeat kev) kcode (w & keys %~ S.insert kcode) where kcode = (keysymScancode . keyboardEventKeysym) kev @@ -57,12 +54,11 @@ handlePressedKeyInGame scode w handlePressedKeyInGame _ w = Just w handlePressedKey :: Bool -> Scancode -> World -> Maybe World -handlePressedKey True _ w = Just w +handlePressedKey True _ w = Just w handlePressedKey _ scode w - | null (_menuLayers w) - = handlePressedKeyInGame scode w - | otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w -handlePressedKey _ _ w = Just w + | null (_menuLayers w) = handlePressedKeyInGame scode w + | otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w +handlePressedKey _ _ w = Just w debugKey :: Scancode -> World -> Maybe World debugKey scancode w @@ -78,7 +74,7 @@ spaceAction w = if _carteDisplay w w & carteCenter .~ theLoc else case listToMaybe $ _closeActiveObjects w of - Just (Left flit) -> pickUpItem flit w + Just (Left flit) -> pickUpItem 0 flit w Just (Right but) -> updateTopCloseObject (_btID but) $ _btEvent but but w Nothing -> w where diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 61db73c2d..6483da1ef 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -49,8 +49,9 @@ roomTreex = do t = treeFromTrunk [[StartRoom] ,[Corridor] - ,[Corridor] - ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 200] + ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 + & rmPS %~ (PS (0,0) 0 (PutCrit miniGunCrit') :) + ] ,[Corridor] ,[Corridor] ,[SpecificRoom . fmap (pure . Right) $ twinSlowDoorChasers 30] diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index afb0deaf7..8dc94efb0 100644 --- a/src/Geometry/Vector.hs +++ b/src/Geometry/Vector.hs @@ -87,10 +87,18 @@ Always positive. -} angleVV :: Point2 -> Point2 -> Float {-# INLINE angleVV #-} -angleVV a b = let ma = magV a - mb = magV b - d = a `dotV` b - in acos $ d / (ma * mb) +angleVV a b = + let ma = magV a + mb = magV b + d = a `dotV` b + in acos $ d / (ma * mb) + +{- | Safe version of 'angleVV' that returns 0 if either vector is null. -} +safeAngleVV :: Point2 -> Point2 -> Float +{-# INLINE safeAngleVV #-} +safeAngleVV a b + | a == (0,0) || b == (0,0) = 0 + | otherwise = angleVV a b {- | Dot product. -}