diff --git a/app/Main.hs b/app/Main.hs index 4aaf012f6..4bceeb1b7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -24,7 +24,7 @@ import Music import Control.Concurrent import Control.Lens import Foreign (Word32) -import Control.Monad (when,void) +import Control.Monad import System.Random import qualified Data.Map as M import qualified Data.IntMap as IM @@ -82,7 +82,7 @@ doPreload = do checkForGlErrors :: IO () checkForGlErrors = do errs <- errors - when (length errs > 0) $ putStrLn $ "GLerror during doLoop: " ++ unwords (map show errs) + unless (null errs) $ putStrLn $ "GLerror during doLoop: " ++ unwords (map show errs) setWindowSize :: Int -> Int -> KeyConfigSDL-> World -> World setWindowSize x y z w = w diff --git a/src/Dodge/AIs.hs b/src/Dodge/AIs.hs deleted file mode 100644 index a732a4ffe..000000000 --- a/src/Dodge/AIs.hs +++ /dev/null @@ -1,104 +0,0 @@ -module Dodge.AIs - ( - ) where -import Dodge.Creature.Stance.Data -import Dodge.Creature.State.Data -import Dodge.Creature.Impulse.Data -import Dodge.Data hiding (Action (..), Impulse (..), Strategy (..)) -import Dodge.Base -import Dodge.Path -import Dodge.SoundLogic -import Dodge.Creature.Action -import Dodge.Creature.Action.Movement -import Dodge.RandomHelp -import Dodge.WorldEvent -import Dodge.Creature.Picture -import Geometry -import Picture - -import Data.List -import Data.Char -import Data.Maybe -import Data.Function -import Data.Graph.Inductive.Graph hiding ((&)) -import Data.Graph.Inductive.PatriciaTree -import Data.Graph.Inductive.Query.SP -import qualified Data.ByteString as B -import qualified Data.Set as S -import qualified Data.IntMap.Strict as IM -import qualified Data.Map as M -import Control.Lens -import Control.Applicative -import Control.Monad -import Control.Monad.State -import Control.Concurrent -import System.Random -import Foreign.ForeignPtr - ----- ----- encircleAI' :: Int -> World -> World ----- encircleAI' 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 ----- flockers = IM.filter (flip (canSeePoint cid) w . _crPos) ----- $ IM.filter (factionIs $ EncircleFlock) ----- $ _creatures w ----- tp | length flockers <= 1 = ypos ----- | otherwise = ypos +.+ ----- f (max 0 (magV (ypos -.- cenp) - 30) ) ----- *.* safeNormalizeV (cpos -.- cenp) ----- where f x = 150 * sigmoid (x-10) ----- cenp = (1 / fromIntegral (length flockers)) *.* ----- foldr1 (+.+) ----- (map _crPos $ IM.elems flockers) ----- combinedRad = _crRad cr + _crRad (you w) ----- 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 tp 10]] w ----- | otherwise -> w ----- (MoveToFor p x:_) ----- | 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 ----- | canSee cid (_yourID w) w && dist cpos ypos < 50 ----- -> mvForward 2 cid $ turnTowardSpeed 0.5 ypos cid ----- $ replaceImpulse [MoveToFor ypos (max 0 (x-1))] w ----- | x == 0 && canSee cid (_yourID w) w ----- -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid ----- $ replaceImpulse [MoveToFor tp 0] w ----- | x == 0 -> replaceImpulse [MoveToFor p 10] w ----- | canSee cid (_yourID w) w ----- -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid ----- $ replaceImpulse [MoveToFor p (x-1)] w ----- | dist cpos p < 20 -> w ----- | otherwise -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid w ----- (MeleeAttack x:_) ----- | x == 0 -> replaceImpulse [WaitFor 5] w ----- | otherwise -> replaceImpulse [MeleeAttack (x-1)] w ----- (WaitFor x:gls)| x == 0 -> replaceImpulse [] w ----- | canSee cid (_yourID w) w ----- -> turnTowardSpeed 0.02 ypos cid ----- $ replaceImpulse [WaitFor (x-1)] w ----- | otherwise -> replaceImpulse [WaitFor (x-1)] w - -errorNormalizeVAI :: Point2 -> Point2 -errorNormalizeVAI (0,0) = error "problem with function: errorNormalizeVAI in DodgeAIs" -errorNormalizeVAI p = normalizeV p - ----------------- diff --git a/src/Dodge/AIs.hs.orig b/src/Dodge/AIs.hs.orig deleted file mode 100644 index a2e4d1215..000000000 --- a/src/Dodge/AIs.hs.orig +++ /dev/null @@ -1,1954 +0,0 @@ -module Dodge.AIs where --- imports {{{ -import Dodge.Data -import Dodge.Base -import Dodge.Path -import Dodge.SoundLogic -import Dodge.CreatureAction -import Dodge.Event -import Dodge.RandomHelp -import Dodge.WorldEvent - -import Geometry -import Picture - -import Data.List -import Data.Char -import Data.Maybe -import Data.Function -import Data.Graph.Inductive.Graph -import Data.Graph.Inductive.PatriciaTree -import Data.Graph.Inductive.Query.SP -import qualified Data.ByteString as B -import Control.Lens -import Control.Applicative -import Control.Monad.State -import Control.Monad - -import System.Random -import qualified Data.Set as S -import qualified Data.IntMap.Strict as IM -import qualified Data.Map as M - -import Foreign.ForeignPtr -import Control.Concurrent - -factionIs :: Faction -> Creature -> Bool -factionIs f c = (_faction $ _crState $ c) == f - -lineOrth :: Point2 -> IM.IntMap Creature -> Point2 -> Point2 -lineOrth ypos crs cpos = p - where ps = map _crPos $ IM.elems crs - cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps - p | dist cen ypos < 20 = ypos - | otherwise = errorClosestPointOnLine 500 ypos (ypos +.+ vNormal (cen -.- ypos)) cpos - -lineUp :: Point2 -> IM.IntMap Creature -> Point2 -> Point2 -lineUp ypos crs cpos = p - where ps = map _crPos $ IM.elems crs - cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps - p = (0.05 *.* ypos) +.+ (0.95 *.* errorClosestPointOnLine 500 cen ypos cpos) - -holdForm :: Point2 -> IM.IntMap Creature -> Point2 -> Point2 -holdForm ypos crs cpos = p - where ps = map _crPos $ IM.elems crs - cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps - p | dist cen ypos < 20 = ypos - | otherwise = ypos +.+ cpos -.- cen - --- not nice, a kind of encircle -spreadOut :: Point2 -> IM.IntMap Creature -> Point2 -> Point2 -spreadOut ypos crs cpos = p - where ps = map _crPos $ IM.elems crs - cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps - p | dist cen ypos < 30 = ypos - | otherwise = ypos +.+ (spreadFactor *.* cpos -.- cen) - spreadFactor | dist ypos cpos > 200 = 1 - | otherwise = 5 ----- ----- -- generalised swarm ai, works out where you go from the position of your flock ----- swarmAI :: (Point -> IM.IntMap Creature -> Point -> Point) -> Int -> World -> World ----- swarmAI f 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 ----- flockers = IM.filter (flip (canSeePoint cid) w . _crPos) ----- $ IM.filter (factionIs $ _faction $ _crState cr) ----- $ _creatures w ----- tp = f ypos flockers cpos ----- combinedRad = _crRad cr + _crRad (you w) ----- replaceImpulse newImpulses = over (creatures . ix cid . crState . goals) ----- (\gs -> newImpulses ++ tail gs) ----- addImpulse newImpulses = over (creatures . ix cid . crState . goals) ----- (\gs -> newImpulses ++ gs) ----- replaceAction newActions = over (creatures . ix cid . crState . goals) ----- (\((_:as):ass) -> (newActions ++ as):ass) ----- addAction 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 ----- -> replaceImpulse [[MoveToFor tp 10]] w ----- | otherwise -> w ----- (MoveToFor p x:_) ----- | dist ypos cpos < combinedRad + 5 ----- && abs ((_crDir cr) - argV (ypos -.- cpos)) < pi/4 -- THIS WON'T WORK ----- -- think about when crdir is 0.1 and yposdir is (2pi - epsilon) ----- ----- && x == 0 ----- -> over (creatures . ix cid . crPos) ----- (+.+ (12 *.* errorNormalizeVAI (ypos -.- cpos))) ----- $ replaceAction [MeleeAttack 5] ----- $ damageYou ----- w ----- | canSee cid (_yourID w) w && dist cpos ypos < 50 ----- -> mvForward 2 cid $ turnTowardSpeed 0.5 ypos cid ----- $ replaceAction [MoveToFor ypos (max 0 (x-1))] w ----- | x == 0 && canSee cid (_yourID w) w ----- -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid ----- $ replaceAction [MoveToFor tp 0] w ----- | x == 0 -> replaceAction [MoveToFor p 10] w ----- | canSee cid (_yourID w) w ----- -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid ----- $ replaceAction [MoveToFor p (x-1)] w ----- | dist cpos p < 20 -> w ----- | otherwise -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid w ----- (MeleeAttack x:_) ----- | x == 0 -> replaceAction [WaitFor 5] w ----- | otherwise -> replaceAction [MeleeAttack (x-1)] w ----- (WaitFor x:gls)| x == 0 -> replaceAction [] w ----- | canSee cid (_yourID w) w ----- -> turnTowardSpeed 0.05 ypos cid ----- $ replaceAction [WaitFor (x-1)] w ----- | otherwise -> replaceAction [WaitFor (x-1)] w ----- ----- encircleAI' :: Int -> World -> World ----- encircleAI' 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 ----- flockers = IM.filter (flip (canSeePoint cid) w . _crPos) ----- $ IM.filter (factionIs $ EncircleFlock) ----- $ _creatures w ----- tp | length flockers <= 1 = ypos ----- | otherwise = ypos +.+ ----- f (max 0 (magV (ypos -.- cenp) - 30) ) ----- *.* safeNormalizeV (cpos -.- cenp) ----- where f x = 150 * sigmoid (x-10) ----- cenp = (1 / fromIntegral (length flockers)) *.* ----- foldr1 (+.+) ----- (map _crPos $ IM.elems flockers) ----- combinedRad = _crRad cr + _crRad (you w) ----- replaceImpulse newImpulses = over (creatures . ix cid . crState . goals) ----- (\gs -> newImpulses ++ tail gs) ----- addImpulse newImpulses = over (creatures . ix cid . crState . goals) ----- (\gs -> newImpulses ++ gs) ----- replaceAction newActions = over (creatures . ix cid . crState . goals) ----- (\((_:as):ass) -> (newActions ++ as):ass) ----- addAction 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 ----- -> replaceImpulse [[MoveToFor tp 10]] w ----- | otherwise -> w ----- (MoveToFor p x:_) ----- | 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))) ----- $ replaceAction [MeleeAttack 5] ----- $ damageYou ----- w ----- | canSee cid (_yourID w) w && dist cpos ypos < 50 ----- -> mvForward 2 cid $ turnTowardSpeed 0.5 ypos cid ----- $ replaceAction [MoveToFor ypos (max 0 (x-1))] w ----- | x == 0 && canSee cid (_yourID w) w ----- -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid ----- $ replaceAction [MoveToFor tp 0] w ----- | x == 0 -> replaceAction [MoveToFor p 10] w ----- | canSee cid (_yourID w) w ----- -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid ----- $ replaceAction [MoveToFor p (x-1)] w ----- | dist cpos p < 20 -> w ----- | otherwise -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid w ----- (MeleeAttack x:_) ----- | x == 0 -> replaceAction [WaitFor 5] w ----- | otherwise -> replaceAction [MeleeAttack (x-1)] w ----- (WaitFor x:gls)| x == 0 -> replaceAction [] w ----- | canSee cid (_yourID w) w ----- -> turnTowardSpeed 0.02 ypos cid ----- $ replaceAction [WaitFor (x-1)] w ----- | otherwise -> replaceAction [WaitFor (x-1)] w - -spawnerAI :: Creature -> World -> (World -> World,StdGen) -> Creature - -> ((World -> World, StdGen), Maybe Creature) -spawnerAI spawn w (f,g) cr = - let dir = _crDir cr - cid = _crID cr - cpos = _crPos cr - ypos = _crPos $ you w - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) - - needChild = length (filter (\cr' -> (cr' ^? crState . faction) == Just (SpawnedBy cid)) - $ IM.elems $ _creatures w) - < 15 - spawnChild = placeCrFaction spawn (SpawnedBy cid) (cpos +.+ rotateV dir (1,0)) cpos (_crDir cr) - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - (WaitFor x:_) | x == 0 && needChild - -> ( (spawnChild . f , g) - ,replaceAction [WaitFor 200] $ over crDir (+ 1) cr - ) - | canSee cid (_yourID w) w - -> ( (f , g) - ,replaceAction [WaitFor (max 0 (x-1))] - $ set (crDir) (argV (ypos -.- cpos)) cr ) - | otherwise -> ( (f , g) - ,replaceAction [WaitFor (max 0 (x-1))] cr) - -placeCrFaction :: Creature -> Faction -> Point2 -> Point2 -> Float -> World -> World -placeCrFaction cr fact p op rot w = over creatures addCr w - where addCr crs = IM.insert (Dodge.Base.newKey crs) - ( set (crState . faction) fact - $ cr {_crPos = p,_crOldPos = op,_crDir = rot,_crID = Dodge.Base.newKey crs} - ) - crs - - -chaseAI :: - World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature) -chaseAI w (f,g') cr = - let cid = _crID cr - cpos = _crPos cr - damageYou = over (creatures . ix 0 . crState . crDamage) addDam - . soundOnce (fromIntegral hitSound) - addDam dams = (( Blunt 100 cpos cpos cpos ) : 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) - randomTurn2 = over crDir (+(signum a)) - isCrowded = (length $ IM.elems $ IM.filter isCloseFaction (_creatures w)) > 2 - isCloseFaction cr' = _faction (_crState cr') == _faction (_crState cr) - && dist cpos (_crPos cr') < 25 - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - [] -> ((f, g') , replaceImpulse [] cr) - (Wait:_) | dist cpos ypos < 900 && hasLOS cpos ypos w - -> ((f ,g') - ,addImpulse [[WaitFor wtime,MoveTo ypos]] cr) - | dist cpos ypos < 900 && hasLOSIndirect cpos ypos w - -> ((f , g') - ,addImpulse [[WaitFor wtime,PathTo ypos]] cr) - | otherwise -> ( (f , g') - ,Just cr) - (WaitFor x:gls)| x == 0 -> ( (f , g') - ,replaceAction [] cr --- $ drawCircleAtForCol cpos 10 (withAlpha 0.5 cyan) - ) - | hasLOS cpos ypos w - -> ( (f, g') - ,replaceAction [WaitFor (x-1)] $ crTurnTowardSpeed 0.05 ypos cr - ) - | otherwise -> ( (f, g') - , replaceAction [WaitFor (x-1)] cr ) - (MoveTo p:gls) - | dist ypos cpos < combinedRad + 5 - && abs ((_crDir cr) - argV (ypos -.- cpos)) < pi/4 -- same error as above - -> ( (damageYou . f , g') - , replaceAction [MeleeAttack 5] $ - over crPos - (+.+ (12 *.* errorNormalizeVAI (ypos -.- cpos))) cr - ) - | hasLOS cpos ypos w -> ( (f , g) - , replaceAction [MoveTo ypos] - $ crMvForward 2.5 $ randomTurn - $ crTurnTowardSpeed 0.05 p cr - ) - | dist p cpos < 10 -> ( (f, g') - , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f ,g' ) - , Just $ crTurnTowardSpeed 0.05 p cr) - | otherwise -> ( (f, g' ) - , Just $ crMvForward 2.5 $ crTurnTowardSpeed 0.05 p cr) - (MoveToFor p x:gls) - | hasLOS cpos ypos w -> - ( (f , g ) - , replaceAction [MoveTo ypos] - $ crMvForward 2.5 $ randomTurn $ crTurnTowardSpeed 0.05 p cr - ) - | dist p cpos < 10 -> ( (f , g) - , replaceAction [] cr) - | x == 0 -> ( (f , g) - , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f , g) - , replaceAction [MoveToFor p (max 0 (x-1))] - $ crTurnTowardSpeed 0.05 p cr) - | otherwise -> ( (f , g) - , replaceAction [MoveToFor p (max 0 (x-1))] - $ crMvForward 2.5 $ crTurnTowardSpeed 0.05 p cr) - (PathTo p:_) - | dist p cpos < 10 -> ( (f , g) - , replaceAction [] cr --- $ drawCircleAtForCol p 10 (withAlpha 0.5 blue) - ) - | hasLOS cpos p w -> ( (f , g) - , addAction [MoveToFor p 10] cr --- $ drawCircleAtForCol p 10 (withAlpha 0.5 green) - ) - | otherwise -> - --((f, g) , replaceAction [] cr) --- case makePathBetweenPs cpos p w of --- Just (q:_) -> ( (f , g) --- --- , addAction [MoveToFor q 10] cr --- ) --- _ -> ((f , g) --- --- , replaceAction [] cr --- ) - case pointTowardsImpulse cpos p w of - Just q -> ( (f , g) - - , addAction [MoveToFor q 10] cr - ) - _ -> ((f , g) - - , replaceAction [] cr - ) - --- case pointTowardsImpulse' cpos p w of - -- Right q -> addAction [MoveToFor q 10] ------ let ns = map fst $ concatMap doublePair $ _pathGraph' w ------ a' = listToMaybe $ sortBy (compare `on` dist cpos) $ ns ------ b' = listToMaybe $ sortBy (compare `on` dist p) $ ns ------ g :: World -> World ------ g = fromMaybe id $ fmap (\p -> drawCircleAtForCol p 10 yellow) a' ------ h = fromMaybe id $ fmap (\p -> drawCircleAtForCol p 10 blue) b' ------ incf = incidenceToFunction $ pairsToIncidence ------ $ concatMap doublePair $ _pathGraph' w ------ as :: [Point] ------ as = concat $ maybeToList $ fmap incf a' ------ g' w = foldr (\p -> drawCircleAtForCol p 5 orange) w as ------ h' qs w = foldr (\p -> drawCircleAtForCol p 5 orange) w qs ------ in case makePath' <$> return incf <*> b' <*> a' of ------ Just (q:qs) -> ( f . h' qs ------ . drawCircleAtForCol q 10 magenta ------ , addAction [MoveToFor q 10] cr ------ -- $ drawLineForCol ((cpos : (concat $ maybeToList $ makePathBetweenPs ------ -- cpos p w)) ++ [p]) 50 red ------ ) -------- Left s -> error s -------- - -> (f,cr) ------ _ -> ( f ------ . g . h . g' ------ , replaceAction [] cr ------ ) - (MeleeAttack x:_) - | x == 0 -> ( (f , g) - , replaceAction [WaitFor wtime] cr ) - | otherwise -> ( (f , g) - , replaceAction [MeleeAttack (x-1)] cr ) - ----- 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 ----- replaceImpulse newImpulses = over (creatures . ix cid . crState . goals) ----- (\gs -> newImpulses ++ tail gs) ----- addImpulse newImpulses = over (creatures . ix cid . crState . goals) ----- (\gs -> newImpulses ++ gs) ----- replaceAction newActions = over (creatures . ix cid . crState . goals) ----- (\((_:as):ass) -> (newActions ++ as):ass) ----- addAction 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 ----- -> replaceImpulse [[MoveToFor ypos 10]] w ----- | canSeeIndirect cid (_yourID w) w ----- -> addImpulse [[PathTo ypos]] w ----- | otherwise -> replaceImpulse [] w ----- (WaitFor x:gls)| x == 0 -> replaceAction [] w ----- | canSee cid (_yourID w) w ----- -> turnTowardSpeed 0.05 ypos cid ----- $ replaceAction [WaitFor (x-1)] w ----- | otherwise -> replaceAction [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))) ----- $ replaceAction [MeleeAttack 5] ----- $ damageYou ----- w ----- | x == 0 && isCrowded -> replaceAction [] $ randomTurn2 w ----- | canSee cid (_yourID w) w -> replaceImpulse [[MoveToFor ypos (max 0 (x-1))]] ----- $ mvForward 2.5 cid $ randomTurn $ turnTowardSpeed 0.05 p cid w ----- | dist p cpos < 10 -> replaceAction [] w ----- | x == 0 -> replaceAction [] w ----- -- | not (canSeePoint cid p w) -> replaceAction [PathTo p] w ----- -- | not (canSeePoint cid p w) -> replaceAction [] w ----- | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 ----- -> replaceAction [MoveToFor p (max 0 (x-1))] $ turnTowardSpeed 0.05 p cid w ----- | otherwise -> replaceAction [MoveToFor p (max 0 (x-1))] ----- $ mvForward 2.5 cid $ turnTowardSpeed 0.05 p cid w ----- (PathTo p:_) ----- | dist p cpos < 10 -> replaceAction [] w ----- | canSeePoint cid p w -> addAction [MoveToFor p 10] w ----- | otherwise -> ----- case pointTowardsImpulse' cpos p w of ----- Right q -> addAction [MoveToFor q 10] ----- -- $ drawCircleAtForCol q 10 magenta ----- -- $ drawLineForCol ((cpos : (concat $ maybeToList $ makePathBetweenPs ----- -- cpos p w)) ++ [p]) 50 red ----- w ----- --Left s -> error s ----- _ -> replaceAction [] w ----- (MeleeAttack x:_) ----- | x == 0 -> replaceAction [WaitFor wtime] w ----- | otherwise -> replaceAction [MeleeAttack (x-1)] w ----- (TrackYou:_) -> addImpulse [[WaitFor wtime,PathTo ypos]] $ set randGen g1 w ----- (InitTrackYou:_)| canSeeIndirect cid (_yourID w) w -> replaceImpulse [[TrackYou]] w ----- | otherwise -> w ----- (Guard p p':_) | canSeeIndirect cid (_yourID w) w ----- -> addImpulse [[WaitFor wtime,PathTo ypos]] $ set randGen g1 w ----- | dist cpos p > 10 ----- -> addImpulse [[PathTo p]] w ----- | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 ----- -> turnTowardSpeed 0.05 p' cid w ----- | otherwise -> w ----- (InitGuard :_) -> replaceImpulse [[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) -miniAI w (f,g) cr = - let cpos = _crPos cr - cid = _crID cr - ypos = _crPos $ you w - wp = _crInv cr IM.! _crInvSel cr - (aimtime,g1) = randomR (80,120) g - noAmmo = 0 == _wpLoadedAmmo wp - turnCloseSlow p | errorAngleVV 22 (p -.- cpos) - (unitVectorAtAngle (_crDir cr)) < 0.4 - = crTurnTowardSpeed 0.01 p - | otherwise = crTurnTowardSpeed 0.05 p - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) --- autoFireTweak p | _wpIsAuto wp = Just --- | otherwise = replaceImpulse [[AimAt p (_itUseRate wp * 2)]] - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - [] | canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | otherwise -> ( ( f , g ) - , replaceImpulse [] cr - ) - (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | x == 0 -> ( (f ,g ), replaceAction [] cr ) - | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) - (MoveToFor p x:gls) - | canSeeFire cpos ypos w -> ( (f , g1) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | x == 0 -> ( (f , g) - , replaceAction [] cr - ) - | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) - | otherwise -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 - $ crTurnTowardSpeed 0.05 p cr ) - (PathTo p:_) | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr ) - | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) - | otherwise -> case pointTowardsImpulse cpos p w of - Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) - _ -> ( (f , g) , replaceAction [] cr ) - (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) - , replaceImpulse [[Reload - ,PathTo p - ,WaitFor 50 - --,Search 1 ,WaitFor 100 - ]] - cr - ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (tryUseItem cid . f , g) - , replaceImpulse [[FireAt ypos]] $ turnCloseSlow p cr - ) - | pathToPointFireable cid p w - -> ( (tryUseItem cid . f , g) - , Just $ turnCloseSlow p cr - ) - | otherwise -> ( (f , g) - , replaceImpulse [[PathTo p,WaitFor 50 ]] cr - ) - (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) - | canSeeFireVisionAny cid (_yourID w) w - -> ( (f , g) - , Just $ turnCloseSlow ypos cr - ) -- no longer chase if see you when reloading - -- $ replaceAction [] w - | otherwise -> ( (f , g) , Just cr) - (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) - | otherwise - -> ( ( f , g1) - , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) - , Search (i-1) - ] cr - ) - (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w - -> ( ( f , g1) - , addImpulse [[AimAt ypos (0)]] cr - ) - | dist cpos p > 10 - -> ( (f,g) , addImpulse [[PathTo p]] cr) - | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 - -> ( (f,g) - ,Just $ crTurnTowardSpeed 0.05 p' cr) - | otherwise -> ( (f,g) ,Just cr) - (InitGuard :_) -> ( (f,g) - ,replaceImpulse [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr - ) - (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ turnCloseSlow p cr) - | otherwise - -> ( (f,g) , replaceAction [AimAt p (i-1)] $ turnCloseSlow p cr) - -strafeOrChargeAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -strafeOrChargeAI inRange outRange w (f,g) cr = - let cpos = _crPos cr - cid = _crID cr - ypos = _crPos $ you w - wp = _crInv cr IM.! _crInvSel cr - (aimtime,g1) = randomR (80,120) g - noAmmo = 0 == _wpLoadedAmmo wp - inR p aRange = dist p cpos < aRange - inA p = errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.2 - inA' p = errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < pi/2 - strafeClockwise p | dist cpos p > 200 = crTurnTowardSpeed 0.05 p . crMvForward 3 - | dist cpos p < 80 = crTurnTowardSpeed 0.05 p . crMvForward (-3) - | errorAngleVV 22 (p' -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4 - = crTurnTowardSpeed 0.01 p' . crStrafeLeft 3 - | otherwise - = crTurnTowardSpeed 0.05 p' . crStrafeLeft 3 - where v = vNormal $ p -.- cpos - p' = p +.+ 0.5 *.* (v -.- 20 *.* (normalizeV v)) - strafeCloseSlow p | dist cpos p > 200 = crTurnTowardSpeed 0.05 p . crMvForward 3 - | dist cpos p < 80 = crTurnTowardSpeed 0.05 p . crMvForward (-3) - | errorAngleVV 22 (p' -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4 - = crTurnTowardSpeed 0.01 p' . crStrafeLeft 3 - | otherwise - = crTurnTowardSpeed 0.05 p' . crStrafeLeft 3 - where v = vNormal $ p -.- cpos - p' = p +.+ 0.5 *.* (v -.- 20 *.* (normalizeV v)) - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) --- autoFireTweak p | _wpIsAuto wp = Just --- | otherwise = replaceImpulse [[AimAt p (_itUseRate wp * 2)]] - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - [] | canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | otherwise -> ( ( f , g ) - , replaceImpulse [] cr - ) - (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] - cr - ) - | x == 0 -> ( (f ,g ), replaceAction [] cr ) - | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) - (MoveToFor p x:gls) - | canSeeFire cpos ypos w -> ( (f , g1) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | x == 0 -> ( (f , g) - , replaceAction [] cr - ) - | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) - | otherwise -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 - $ crTurnTowardSpeed 0.05 p cr ) - (PathTo p:_) | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr ) - | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) - | otherwise -> case pointTowardsImpulse cpos p w of - Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) - _ -> ( (f , g) , replaceAction [] cr ) - (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) - , replaceImpulse [[Reload - ,PathTo p - ,WaitFor 50 - --,Search 1 ,WaitFor 100 - ]] - cr - ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (tryUseItem cid . f , g) - , replaceImpulse [[FireAt ypos]] $ strafeCloseSlow p cr - ) - | pathToPointFireable cid p w - -> ( (tryUseItem cid . f , g) - , Just $ strafeCloseSlow p cr - ) - | otherwise -> ( (f , g) - , replaceImpulse [[PathTo p,WaitFor 50 ]] cr - ) - (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) - | canSeeFireVisionAny cid (_yourID w) w - -> ( (f , g) - , Just $ strafeCloseSlow ypos cr - ) -- no longer chase if see you when reloading - -- $ replaceAction [] w - | otherwise -> ( (f , g) , Just cr) - (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) - | otherwise - -> ( ( f , g1) - , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) - , Search (i-1) - ] cr - ) - (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w - -> ( ( f , g1) - , addImpulse [[AimAt ypos (2*aimtime)]] cr - ) - | dist cpos p > 10 - -> ( (f,g) , addImpulse [[PathTo p]] cr) - | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 - -> ( (f,g) - ,Just $ crTurnTowardSpeed 0.05 p' cr) - | otherwise -> ( (f,g) ,Just cr) - (InitGuard :_) -> ( (f,g) - ,replaceImpulse [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr - ) - (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ strafeCloseSlow p - cr - ) - | otherwise - -> ( (f,g) , replaceAction [AimAt p (i-1)] $ strafeCloseSlow p cr) - -chargeAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -chargeAI w (f,g) cr = - let cpos = _crPos cr - cid = _crID cr - ypos = _crPos $ you w - (aimtime,g') = randomR (80,120::Float) g - wp = _crInv cr IM.! _crInvSel cr - fTurn p | errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4 - = crTurnTowardSpeed 0.005 p - | errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < 1 - = crTurnTowardSpeed 0.05 p - | otherwise - = crTurnTowardSpeed 0.2 p - noAmmo = 0 == _wpLoadedAmmo wp - updateSearch = over (crState . goals) f - where f (g:_:h:gs) = (g:[PathTo ypos]:h:gs) - f (g:gs) = (g:[PathTo ypos]:gs) - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - (MoveTo p:_) - | dist cpos ypos < 40 -> ((f,g) , replaceAction [Fire] cr) - | canSeeFire cpos ypos w -> ((f,g), Just . crMvBy (3,0) . fTurn ypos $ cr) - | otherwise -> ((f,g), Just . crMvBy (3,0) . fTurn p $ cr) - (Fire:_) - | dist cpos ypos < 60 && canSeeFire cpos ypos w - -> ((tryUseItem cid . f,g), Just $ fTurn ypos cr) - | otherwise -> ((f,g), replaceAction [] cr) - [] | canSeeFireVisionAny cid (_yourID w) w - -> ( ( f , g' ) , addAction [MoveTo ypos] cr) - | otherwise -> ( ( f , g' ) , Just cr) - (WaitFor x:gls)| x == 0 -> ( (f ,g' ), replaceAction [] cr ) - | otherwise -> ( (f ,g' ), replaceAction [WaitFor (x-1)] cr ) - (MoveToFor p x:gls) - | canSeeFire cpos ypos w -> ( (f , g') - , replaceAction [MoveTo ypos] cr - ) - | x == 0 -> ( (f , g') - , replaceAction [] cr - ) - | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f , g') - , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) - | otherwise -> ( (f , g') - , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 - $ crTurnTowardSpeed 0.05 p cr ) - (PathTo p:_) | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr ) - | hasLOS cpos p w -> ( (f , g') , addAction [MoveToFor p 100] cr ) - | otherwise -> case pointTowardsImpulse cpos p w of - Just q -> ( (f , g') , addAction [MoveToFor q 100] cr ) - _ -> ( (f , g') , replaceAction [] cr ) - (Init:_) -> ((f,g), replaceAction [] cr) - -launcherAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -launcherAI inRange outRange w (f,g) cr = - let cpos = _crPos cr - cid = _crID cr - ypos = _crPos $ you w - yposl x = ypos -.- x *.* (vNormal $ normalizeV $ ypos -.- cpos) - yposr x = ypos +.+ x *.* (vNormal $ normalizeV $ ypos -.- cpos) - (aimtime,g') = randomR (80,120) g - (recupTime,_) = randomR (0,50) g - wp = _crInv cr IM.! _crInvSel cr - noAmmo = 0 == _wpLoadedAmmo wp || _wpReloadState wp /= 0 - updateSearch = over (crState . goals) f - where f (g:_:h:gs) = (g:[PathTo ypos]:h:gs) - f (g:gs) = (g:[PathTo ypos]:gs) - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) - ts = take 3 $ randomRs (20,25) g - retreatActions = SetPosture Aiming - : Fire - : TurnByFor 0.16 20 - : SetPosture AtEase - : MoveByFor (3,0) 18 - : SetPosture Aiming - : Fire - : TurnByFor (-0.16) 20 - : SetPosture AtEase - : MoveByFor (3,0) 10 - : TurnToward ypos - -- : WaitFor 12 - -- : Fire - -- : WaitFor 20 - : SetPosture Aiming - : Fire - : WaitFor 60 - : [SetPosture AtEase] - strafeLeftActions = TurnToward (yposr 30) - : SetPosture Aiming - : (concatMap (\t -> [Fire,MoveByFor (0,3) t]) ts) - ++ [SetPosture AtEase] - strafeRightActions = TurnToward (yposl 30) - : SetPosture Aiming - : (concatMap (\t -> [Fire,MoveByFor (0,-3) t]) ts) - ++ [SetPosture AtEase] - rota a = cpos +.+ rotateV a (ypos -.- cpos) - (a2:a3:a4:a5:_) = evalState (takeOne [[0.1,0.15,0.5,1.5] - --,[0.1,0.15,0.5,1.5] - -- ,[0.2,0.3,0.6,1] - -- ,[0.2,0.3,0.5,0.8] - -- ,[0.2,0.3,0.5,1] - -- ,[0.1,0.2,0.5,0.9] - -- ,[0.1,0.2,0.4,0.7] - -- ,[0.1,0.2,0.3,0.4] - ] - ) g - curveLeft = TurnToward (rota $ negate a2) - : SetPosture Aiming - : Fire - : TurnToward (rota $ negate a3) - : WaitFor 20 - : Fire - : TurnToward (rota $ negate a4) - : WaitFor 20 - : Fire - : TurnToward (rota $ negate a5) - : SetPosture AtEase - : [MoveByFor (-3,0) 40] - curveRight = TurnToward (rota a2) - : SetPosture Aiming - : Fire - : TurnToward (rota a3) - : WaitFor 20 - : Fire - : TurnToward (rota a4) - : WaitFor 20 - : Fire - : TurnToward (rota a5) - : SetPosture AtEase - : [MoveByFor (-3,0) 40] - strafeProb :: Float - strafeProb | dist cpos ypos > 350 = 40 - | otherwise = 10 - retreatProb | dist cpos ypos < 100 = 80 - | dist cpos ypos < 200 = 40 - | otherwise = 0 - curveLeftProb = 20 - curveRightProb = 20 - -- | dist cpos ypos < 200 = 1 - -- | otherwise = 0 - fireActions = -- TurnToward ypos : - (evalState (takeOneWeighted - [curveLeftProb,curveRightProb - ,strafeProb,strafeProb,retreatProb] - [curveLeft - ,curveRight - ,strafeLeftActions - ,strafeRightActions - ,retreatActions - ] - ) $ g - ) - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - (TurnTo p:_) -> ( (f,g') , replaceAction [] . crTurnTo p $ cr) - (TurnByFor a 0:_) -> ( (f,g') , replaceAction [] . over crDir (+a) $ cr) - (TurnByFor a i:_) -> ( (f,g') , replaceAction [TurnByFor a (i-1)] . over crDir (+a) $ cr) - (SetPosture pture:_) -> ((f,g), replaceAction [] $ set (crState . stance . posture) pture cr) - (MoveByFor p 0:_) -> ((f,g'), replaceAction [] . crMvBy p $ cr) - (MoveByFor p i:_) -> ((f,g'), replaceAction [MoveByFor p (i-1)] . crMvBy p $ cr) - (Fire:_) | collidePointWallsSimple cpos (cpos +.+ 40 *.* unitVectorAtAngle (_crDir cr)) - (wallsAlongLine cpos (cpos +.+ 40 *.* unitVectorAtAngle (_crDir cr)) w) - -> ((f,g),replaceAction [] cr) - | otherwise -> ((tryUseItem cid . f,g'), replaceAction [] cr) - (ImpulseID i (MoveByFor p 0):_) -> ((f,g'), replaceAction [] . crMvBy p $ cr) - (ImpulseID i (MoveByFor p x):_) - | canSeeFire cpos (aCrPos i w) w - -> ( (f,g') - , replaceAction [ImpulseID i (MoveByFor p (x-1))] - . crMvBy p - . crTurnTowardSpeed 0.01 (aCrPos i w) - $ cr - ) - | otherwise - -> ( (f,g') - , replaceAction [ImpulseID i (MoveForwardFor (x-1))] - . crMvBy p - $ cr - ) - (TurnToward p:_) - | errorAngleVV 99 (p -.- cpos) (unitVectorAtAngle $ _crDir cr) > 2 - -> ( (f,g') - , Just . crTurnTowardSpeed 0.5 p - $ cr - ) - | errorAngleVV 99 (p -.- cpos) (unitVectorAtAngle $ _crDir cr) > 0.2 - -> ( (f,g') - , Just . crTurnTowardSpeed 0.1 p - $ cr - ) - | otherwise - -> ( (f,g') - , replaceAction [] - . crTurnTo p - $ cr - ) - [] | noAmmo -> ( (tryUseItem cid . f, g') - , addAction [Reload] cr - ) - | canSeeFireVisionAny cid (_yourID w) w - -> ( ( f , g' ) - -- , addAction (WaitFor 9:fireActions) - , addAction (WaitFor 9:fireActions) - $ updateSearch cr - ) - | otherwise -> ( ( f , g' ) - , replaceImpulse [] cr - ) - (WaitFor x:gls)| x == 0 -> ( (f ,g' ), replaceAction [] cr ) - | otherwise -> ( (f ,g' ), replaceAction [WaitFor (x-1)] cr ) - (MoveToFor p x:gls) - | canSeeFire cpos ypos w -> ( (f , g') - , replaceImpulse [[],[PathTo ypos]] cr - ) - | x == 0 -> ( (f , g') - , replaceAction [] cr - ) - | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f , g') - , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) - | otherwise -> ( (f , g') - , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 - $ crTurnTowardSpeed 0.05 p cr ) - (PathTo p:_) | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr ) - | hasLOS cpos p w -> ( (f , g') , addAction [MoveToFor p 100] cr ) - | otherwise -> case pointTowardsImpulse cpos p w of - Just q -> ( (f , g') , addAction [MoveToFor q 100] cr ) - _ -> ( (f , g') , replaceAction [] cr ) - (Reload:_) | _wpReloadState wp == 0 -> ( (f , g') , replaceAction [WaitFor recupTime] cr ) - | canSeeFireVisionAny cid (_yourID w) w - -> ( (f , g') - , Just $ cr - ) -- no longer chase if see you when reloading - -- $ replaceAction [] w - | otherwise -> ( (f , g') , Just cr) - (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w - -> ( ( f , g') - , addImpulse [[WaitFor aimtime],[PathTo ypos]] cr - ) - | dist cpos p > 10 - -> ( (f,g') , addImpulse [[PathTo p]] cr) - | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 - -> ( (f,g') - ,Just $ crTurnTowardSpeed 0.05 p' cr) - | otherwise -> ( (f,g') ,Just cr) - (Init :_) -> ( (f,g') - ,replaceImpulse [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr - ) -dodgeAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -dodgeAI inRange outRange w (f,g) cr = - let cpos = _crPos cr - cid = _crID cr - ypos = _crPos $ you w - yposl x = ypos -.- x *.* (vNormal $ normalizeV $ ypos -.- cpos) - yposr x = ypos +.+ x *.* (vNormal $ normalizeV $ ypos -.- cpos) - (aimtime,g') = randomR (0,120) g - (recupTime,_) = randomR (0,50) g - wp = _crInv cr IM.! _crInvSel cr - noAmmo = 0 == _wpLoadedAmmo wp - updateSearch = over (crState . goals) f - where f (g:_:h:gs) = (g:[PathTo ypos]:h:gs) - f (g:gs) = (g:[PathTo ypos]:gs) - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) - retreatOffset = let a | dist cpos ypos < 50 = 0 - | isLeftOfA (_crDir cr) (argV $ ypos -.- cpos) - = -0.7 - | otherwise = 0.7 - in fromMaybe ypos - $ intersectLineLine' cpos - (cpos +.+ rotateV a (ypos -.- cpos)) - ypos - (ypos +.+ vNormal (cpos -.- ypos)) - ts = take 5 $ randomRs (7,10) g - chargeActions = TurnToward ypos - : (ImpulseID 0 (MoveByFor (3,0) 15)) - : (concatMap (\t -> [ImpulseID 0 (MoveByFor (3,0) t),Fire]) ts) - retreatActions = TurnToward retreatOffset - :(ImpulseID 0 (MoveByFor (-3,0) 9)) - : (concatMap (\t -> [ImpulseID 0 (MoveByFor (-3,0) t),Fire]) ts) - strafeLeftActions = TurnToward (yposr 150) : MoveByFor (0,3) 4 - : (concatMap (\t -> [MoveByFor (0,3) t,Fire]) ts) - strafeRightActions = TurnToward (yposl 150) : MoveByFor (0,-3) 4 - : (concatMap (\t -> [MoveByFor (0,-3) t,Fire]) ts) - chargeProb :: Float - chargeProb | dist cpos ypos > 300 = 5 - | dist cpos ypos > 150 = 1 - | otherwise = 0 - strafeProb | dist cpos ypos > 150 = 1 - | otherwise = 0 - retreatProb | dist cpos ypos < 200 = 1 - | otherwise = 0 - fireActions = -- TurnToward ypos : - (evalState (takeOneWeighted - [chargeProb,retreatProb,strafeProb,strafeProb] - [chargeActions - ,retreatActions - ,strafeLeftActions - ,strafeRightActions - ] - ) $ g - ) - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - (MoveByFor p 0:_) -> ((f,g'), replaceAction [] . crMvBy p $ cr) - (MoveByFor p i:_) -> ((f,g'), replaceAction [MoveByFor p (i-1)] . crMvBy p $ cr) - (Fire:_) -> ((tryUseItem cid . f,g'), replaceAction [] cr) - (ImpulseID i (MoveByFor p 0):_) -> ((f,g'), replaceAction [] . crMvBy p $ cr) - (ImpulseID i (MoveByFor p x):_) - | canSeeFire cpos (aCrPos i w) w - -> ( (f,g') - , replaceAction [ImpulseID i (MoveByFor p (x-1))] - . crMvBy p - . crTurnTowardSpeed 0.01 (aCrPos i w) - $ cr - ) - | otherwise - -> ( (f,g') - , replaceAction [ImpulseID i (MoveByFor p (x-1))] - . crMvBy p $ cr - ) - (TurnToward p:_) - | errorAngleVV 99 (p -.- cpos) (unitVectorAtAngle $ _crDir cr) > 2 - -> ( (f,g') - , Just . crTurnTowardSpeed 0.2 p - $ cr - ) - | errorAngleVV 99 (p -.- cpos) (unitVectorAtAngle $ _crDir cr) > 0.2 - -> ( (f,g') - , Just . crTurnTowardSpeed 0.1 p - $ cr - ) - | otherwise - -> ( (f,g') - , replaceAction [] - $ cr - ) - [] | noAmmo -> ( (tryUseItem cid . f, g') , addAction [Reload] cr) - | canSeeFireVisionAny cid (_yourID w) w - -> ( ( f , g' ) , addAction (WaitFor 9:fireActions) $ updateSearch cr) - | otherwise -> ( ( f , g' ) , replaceImpulse [] cr) - (WaitFor x:gls)| x == 0 -> ( (f ,g' ), replaceAction [] cr ) - | otherwise -> ( (f ,g' ), replaceAction [WaitFor (x-1)] - $ crTurnTowardSpeed 0.05 ypos cr ) - (MoveToFor p x:gls) - | canSeeFire cpos ypos w -> ( (f , g') - , replaceImpulse [[],[PathTo ypos]] cr - ) - | x == 0 -> ( (f , g') - , replaceAction [] cr - ) - | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f , g') - , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) - | otherwise -> ( (f , g') - , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 - $ crTurnTowardSpeed 0.05 p cr ) - (PathTo p:_) | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr ) - | hasLOS cpos p w -> ( (f , g') , addAction [MoveToFor p 100] cr ) - | otherwise -> case pointTowardsImpulse cpos p w of - Just q -> ( (f , g') , addAction [MoveToFor q 100] cr ) - _ -> ( (f , g') , replaceAction [] cr ) - (Reload:_) | _wpReloadState wp == 0 -> ( (f , g') , replaceAction [WaitFor recupTime] cr ) - | otherwise -> ( (f , g') , Just cr) - (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w - -> ( ( f , g') - , addImpulse [[WaitFor aimtime],[PathTo ypos]] cr - ) - | dist cpos p > 10 - -> ( (f,g') , addImpulse [[PathTo p]] cr) - | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 - -> ( (f,g') - ,Just $ crTurnTowardSpeed 0.05 p' cr) - | otherwise -> ( (f,g') ,Just cr) - (InitGuard :_) -> ( ( f,g') --- (InitGuard :_) -> ( (over lightSources (IM.insert cid (crLight cid)) . f,g') - ,replaceImpulse [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr - ) - (x:_) -> error $ "missing the following pattern in case expression:" ++ show x - -logistic :: Float -> Float -> Float -> (Float -> Float) -logistic x0 l k x = l / (1 + exp (k*(x0 - x))) - - -circleClockwiseAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -circleClockwiseAI inRange outRange w (f,g) cr = - let cpos = _crPos cr - cid = _crID cr - ypos = _crPos $ you w - wp = _crInv cr IM.! _crInvSel cr - (aimtime,g1) = randomR (80,120) g - noAmmo = 0 == _wpLoadedAmmo wp - inR p aRange = dist p cpos < aRange - inA p = errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.2 - inA' p = errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < pi/2 - strafeCloseSlow p | dist cpos p > 200 = crTurnTowardSpeed 0.05 p . crMvForward 3 - | dist cpos p < 80 = crTurnTowardSpeed 0.05 p . crMvForward (-3) - | errorAngleVV 22 (p' -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4 - = crTurnTowardSpeed 0.01 p' . crStrafeLeft 3 - | otherwise - = crTurnTowardSpeed 0.05 p' . crStrafeLeft 3 - where v = vNormal $ p -.- cpos - p' = p +.+ 0.5 *.* (v -.- 20 *.* (normalizeV v)) - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) --- autoFireTweak p | _wpIsAuto wp = Just --- | otherwise = replaceImpulse [[AimAt p (_itUseRate wp * 2)]] - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - [] | canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | otherwise -> ( ( f , g ) - , replaceImpulse [] cr - ) - (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] - cr - ) - | x == 0 -> ( (f ,g ), replaceAction [] cr ) - | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) - (MoveToFor p x:gls) - | canSeeFire cpos ypos w -> ( (f , g1) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | x == 0 -> ( (f , g) - , replaceAction [] cr - ) - | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) - | otherwise -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 - $ crTurnTowardSpeed 0.05 p cr ) - (PathTo p:_) | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr ) - | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) - | otherwise -> case pointTowardsImpulse cpos p w of - Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) - _ -> ( (f , g) , replaceAction [] cr ) - (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) - , replaceImpulse [[Reload - ,PathTo p - ,WaitFor 50 - --,Search 1 ,WaitFor 100 - ]] - cr - ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (tryUseItem cid . f , g) - , replaceImpulse [[FireAt ypos]] $ strafeCloseSlow p cr - ) - | pathToPointFireable cid p w - -> ( (tryUseItem cid . f , g) - , Just $ strafeCloseSlow p cr - ) - | otherwise -> ( (f , g) - , replaceImpulse [[PathTo p,WaitFor 50 ]] cr - ) - (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) - | canSeeFireVisionAny cid (_yourID w) w - -> ( (f , g) - , Just $ strafeCloseSlow ypos cr - ) -- no longer chase if see you when reloading - -- $ replaceAction [] w - | otherwise -> ( (f , g) , Just cr) - (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) - | otherwise - -> ( ( f , g1) - , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) - , Search (i-1) - ] cr - ) - (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w - -> ( ( f , g1) - , addImpulse [[AimAt ypos (2*aimtime)]] cr - ) - | dist cpos p > 10 - -> ( (f,g) , addImpulse [[PathTo p]] cr) - | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 - -> ( (f,g) - ,Just $ crTurnTowardSpeed 0.05 p' cr) - | otherwise -> ( (f,g) ,Just cr) - (InitGuard :_) -> ( (f,g) - ,replaceImpulse [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr - ) - (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ strafeCloseSlow p - cr - ) - | otherwise - -> ( (f,g) , replaceAction [AimAt p (i-1)] $ strafeCloseSlow p cr) - -twitchMissAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -twitchMissAI inRange outRange w (f,g) cr = - let cpos = _crPos cr - yposl = ypos +.+ 25 *.* normalizeV (vNormal (cpos -.- ypos)) - yposr = ypos -.- 25 *.* normalizeV (vNormal (cpos -.- ypos)) - yposoff = evalState (takeOne [yposl,yposr]) $ _randGen w - cid = _crID cr - ypos = _crPos $ you w - wp = _crInv cr IM.! _crInvSel cr - fireRate = fromMaybe 0 $ wp ^? itUseRate - noAmmo = 0 == _wpLoadedAmmo wp - strafeCloseSlow p | errorAngleVV 22 (p -.- cpos) - (unitVectorAtAngle (_crDir cr)) < 0.1 - = crTurnTowardSpeed 0.01 p . crMvForward closeDist - | otherwise - = crTurnAndStrafeIn inOrOut 0.05 p - where inOrOut | dist p cpos < inRange = -1 - | dist p cpos < outRange = 0 - | otherwise = 1 - closeDist | dist p cpos < inRange = -1 - | dist p cpos < outRange = 0 - | otherwise = 1 - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) - (t,g') = randomR (fireRate+10,fireRate+15) g - retreatPs = sortBy (compare `on` dist cpos) $ map f $ nRaysRad 8 400 - where f p = fromMaybe (ypos +.+ p) $ fmap fst - $ collidePointWalls ypos (ypos +.+ p) (wallsAlongLine ypos (ypos +.+ p) w) - retreatP' = cpos +.+ 300 *.* (cpos -.- ypos) - retreatP'' = fromMaybe retreatP' $ fmap fst - $ collidePointWalls ypos retreatP' - $ wallsAlongLine ypos retreatP' w - retreatP = head $ sortBy (compare `on` (\p -> dist p ypos < 300)) $ retreatP'' : retreatPs - fireActions = [TurnToward yposoff, Fire, TurnTo ypos, WaitFor t - ,Fire,Fire,Reload,ImpulseID 0 (WaitFor 20),MakeJudgement] - fleeActions = [MoveToFor retreatP 50,MakeJudgement] - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - [] -> ((f,g), replaceImpulse [] cr) - (MakeJudgement:_) - | not (canSeeFire cpos ypos w) -> ((f,g),replaceAction [] cr) - | dist cpos ypos > 400 -> ((f,g), replaceAction [MoveToFor ypos 20] cr) - | dist cpos ypos < 150 -> ((f,g'),replaceAction fleeActions $ crMvBy (3,0) cr) - | otherwise -> ((f,g'),replaceAction fireActions cr) - (ImpulseID i (WaitFor x):gls) - | x == 0 -> ( (f ,g' ), replaceAction [] cr ) - | otherwise -> ( (f ,g' ), replaceAction [ImpulseID i (WaitFor (x-1))] - $ strafeCloseSlow ypos cr ) - (WaitFor x:gls)| x == 0 -> ( (f ,g' ), replaceAction [] cr ) - | otherwise -> ( (f ,g' ), replaceAction [WaitFor (x-1)] cr ) - (MoveToFor p x:gls) - | x == 0 -> ( (f, g') , replaceAction [] cr) - | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f , g') - , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.5 p cr ) - | otherwise -> ( (f , g') - , replaceAction [MoveToFor p (x-1)] $ crMvForward 3 - $ crTurnTowardSpeed 0.05 p cr ) - (PathTo p:_) - | canSeeFire cpos ypos w -> ((f,g),replaceImpulse [[MakeJudgement]] cr) - | dist p cpos < 10 -> ( (f , g') , replaceAction [] cr ) - | hasLOS cpos p w -> ( (f , g') , addAction [MoveToFor p 50] cr ) - | otherwise -> case pointTowardsImpulse cpos p w of - Just q -> ( (f , g') , addAction [MoveToFor q 50] cr ) - _ -> ( (f , g') , replaceAction [] cr ) - (Fire:gls) -> ( (tryUseItem cid . f , g' ) - , replaceAction [] cr - ) - (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g') , replaceAction [] cr ) - | canSeeFireVisionAny cid (_yourID w) w - -> ( (f , g') - , Just $ strafeCloseSlow ypos cr - ) -- no longer chase if see you when reloading - -- $ replaceAction [] w - | otherwise -> ( (f , g) , Just cr) - (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w - -> ( ( f , g') - , addImpulse [[MakeJudgement]] cr - ) - | dist cpos p > 10 - -> ( (f,g) , addImpulse [[PathTo p]] cr) - | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 - -> ( (f,g) - ,Just $ crTurnTowardSpeed 0.05 p' cr) - | otherwise -> ( (f,g) ,Just cr) - (InitGuard :_) -> ( (f,g) - ,replaceImpulse [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr - ) - (TurnToward p:_) - | errorAngleVV 99 (p -.- cpos) (unitVectorAtAngle $ _crDir cr) > 2 - -> ( (f,g') , Just . crTurnTowardSpeed 0.2 p $ cr) - | errorAngleVV 99 (p -.- cpos) (unitVectorAtAngle $ _crDir cr) > 0.2 - -> ( (f,g') , Just . crTurnTowardSpeed 0.1 p $ cr) - | otherwise - -> ( (f,g') , replaceAction [] . crTurnTo p $ cr) - (TurnTo p:_) -> ( (f,g') , replaceAction [] . crTurnTo p $ cr) - -closeToRangeAI :: Float -> Float -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -closeToRangeAI inRange outRange w (f,g) cr = - let cpos = _crPos cr - cid = _crID cr - ypos = _crPos $ you w - wp = _crInv cr IM.! _crInvSel cr - fireRate = fromMaybe 0 $ wp ^? itUseRate - (aimtime,g1) = randomR (80,120) g - noAmmo = 0 == _wpLoadedAmmo wp - strafeCloseSlow p | errorAngleVV 22 (p -.- cpos) - (unitVectorAtAngle (_crDir cr)) < 0.1 - = crTurnTowardSpeed 0.01 p . crMvForward closeDist - | otherwise - = crTurnAndStrafeIn inOrOut 0.05 p - where inOrOut | dist p cpos < inRange = -1.5 - | dist p cpos < outRange = 0 - | otherwise = 1.5 - closeDist | dist p cpos < inRange = -1.5 - | dist p cpos < outRange = 0 - | otherwise = 1.5 - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - [] | canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | otherwise -> ( ( f , g ) - , replaceImpulse [] cr - ) - (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] - cr - ) - | x == 0 -> ( (f ,g ), replaceAction [] cr ) - | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) - (MoveToFor p x:gls) - | canSeeFire cpos ypos w -> ( (f , g1) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | x == 0 -> ( (f , g) - , replaceAction [] cr - ) - | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) - | otherwise -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crMvForward 3 - $ crTurnTowardSpeed 0.05 p cr ) - (PathTo p:_) | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr ) - | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) - | otherwise -> case pointTowardsImpulse cpos p w of - Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) - _ -> ( (f , g) , replaceAction [] cr ) - (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) - , replaceImpulse [[Reload - ,PathTo p - ,WaitFor 50 - --,Search 1 ,WaitFor 100 - ]] - cr - ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (tryUseItem cid . f , g) - , replaceImpulse [[AimAt ypos (fireRate+ aimtime - 80)]] - $ strafeCloseSlow p cr - ) - | pathToPointFireable cid p w - -> ( (tryUseItem cid . f , g) - , Just $ strafeCloseSlow p cr - ) - | otherwise -> ( (f , g) - , replaceImpulse [[PathTo p,WaitFor 50 ]] cr - ) - (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) - | canSeeFireVisionAny cid (_yourID w) w - -> ( (f , g) - , Just $ strafeCloseSlow ypos cr - ) -- no longer chase if see you when reloading - -- $ replaceAction [] w - | otherwise -> ( (f , g) , Just cr) - (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) - | otherwise - -> ( ( f , g1) - , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) - , Search (i-1) - ] cr - ) - (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w - -> ( ( f , g1) - , addImpulse [[AimAt ypos (2*aimtime)]] cr - ) - | dist cpos p > 10 - -> ( (f,g) , addImpulse [[PathTo p]] cr) - | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 - -> ( (f,g) - ,Just $ crTurnTowardSpeed 0.05 p' cr) - | otherwise -> ( (f,g) ,Just cr) - (InitGuard :_) -> ( (f,g) - ,replaceImpulse [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr - ) - (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ strafeCloseSlow p - cr - ) - | otherwise - -> ( (f,g) , replaceAction [AimAt p (i-1)] $ strafeCloseSlow p cr) - -suppressShooterAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -suppressShooterAI w (f,g) cr = - let cpos = _crPos cr - cid = _crID cr - ypos = _crPos $ you w - wp = _crInv cr IM.! _crInvSel cr - (aimtime,g1) = randomR (80,120) g - noAmmo = 0 == _wpLoadedAmmo wp - turnCloseSlow p | errorAngleVV 22 (p -.- cpos) - (unitVectorAtAngle (_crDir cr)) < 0.4 - = crTurnTowardSpeed 0.01 p - | otherwise = crTurnTowardSpeed 0.05 p - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) --- autoFireTweak p | _wpIsAuto wp = Just --- | otherwise = replaceImpulse [[AimAt p (_itUseRate wp * 2)]] - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - [] | canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | otherwise -> ( ( f , g ) - , replaceImpulse [] cr - ) - (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | x == 0 -> ( (f ,g ), replaceAction [] cr ) - | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) - (MoveToFor p x:gls) - | canSeeFire cpos ypos w -> ( (f , g1) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | x == 0 -> ( (f , g) - , replaceAction [] cr - ) - | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) - | otherwise -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 - $ crTurnTowardSpeed 0.05 p cr ) - (PathTo p:_) | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr ) - | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) - | otherwise -> case pointTowardsImpulse cpos p w of - Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) - _ -> ( (f , g) , replaceAction [] cr ) - (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) - , replaceImpulse [[Reload - ,PathTo p - ,WaitFor 50 - --,Search 1 ,WaitFor 100 - ]] - cr - ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (tryUseItem cid . f , g) - , replaceImpulse [[FireAt ypos]] $ turnCloseSlow p cr - ) - | pathToPointFireable cid p w - -> ( (tryUseItem cid . f , g) - , Just $ turnCloseSlow p cr - ) - | otherwise -> ( (f , g) - , replaceImpulse [[PathTo p,WaitFor 50 ]] cr - ) - (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) - | canSeeFireVisionAny cid (_yourID w) w - -> ( (f , g) - , Just $ turnCloseSlow ypos cr - ) -- no longer chase if see you when reloading - -- $ replaceAction [] w - | otherwise -> ( (f , g) , Just cr) - (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) - | otherwise - -> ( ( f , g1) - , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) - , Search (i-1) - ] cr - ) - (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w - -> ( ( f , g1) - , addImpulse [[AimAt ypos (2*aimtime)]] cr - ) - | dist cpos p > 10 - -> ( (f,g) , addImpulse [[PathTo p]] cr) - | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 - -> ( (f,g) - ,Just $ crTurnTowardSpeed 0.05 p' cr) - | otherwise -> ( (f,g) ,Just cr) - (InitGuard :_) -> ( (f,g) - ,replaceImpulse [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr - ) - (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ turnCloseSlow p cr) - | otherwise - -> ( (f,g) , replaceAction [AimAt p (i-1)] $ turnCloseSlow p cr) - -basicShooterAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -basicShooterAI w (f,g) cr = - let cpos = _crPos cr - cid = _crID cr - ypos = _crPos $ you w - wp = _crInv cr IM.! _crInvSel cr - (aimtime,g1) = randomR (80,120) g - noAmmo = 0 == _wpLoadedAmmo wp - turnCloseSlow p | errorAngleVV 22 (p -.- cpos) - (unitVectorAtAngle (_crDir cr)) < 0.4 - = crTurnTowardSpeed 0.01 p - | otherwise = crTurnTowardSpeed 0.05 p - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) --- autoFireTweak p | _wpIsAuto wp = Just --- | otherwise = replaceImpulse [[AimAt p (_itUseRate wp * 2)]] - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - [] | canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | otherwise -> ( ( f , g ) - , replaceImpulse [] cr - ) - (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | x == 0 -> ( (f ,g ), replaceAction [] cr ) - | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) - (MoveToFor p x:gls) - | canSeeFire cpos ypos w -> ( (f , g1) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | x == 0 -> ( (f , g) - , replaceAction [] cr - ) - | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) - | otherwise -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 - $ crTurnTowardSpeed 0.05 p cr ) - (PathTo p:_) | dist p cpos < 10 -> ( (f , g) , replaceAction [] cr ) - | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) - | otherwise -> case pointTowardsImpulse cpos p w of - Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) - _ -> ( (f , g) , replaceAction [] cr ) - (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) - , replaceImpulse [[Reload - ,PathTo p - ,WaitFor 50 - --,Search 1 ,WaitFor 100 - ]] - cr - ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (tryUseItem cid . f , g) - , replaceImpulse [[FireAt ypos]] $ turnCloseSlow p cr - ) - | pathToPointFireable cid p w - -> ( (tryUseItem cid . f , g) - , Just $ turnCloseSlow p cr - ) - | otherwise -> ( (f , g) - , replaceImpulse [[PathTo p,WaitFor 50 ]] cr - ) - (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) - | canSeeFireVisionAny cid (_yourID w) w - -> ( (f , g) - , Just $ turnCloseSlow ypos cr - ) -- no longer chase if see you when reloading - -- $ replaceAction [] w - | otherwise -> ( (f , g) , Just cr) - (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) - | otherwise - -> ( ( f , g1) - , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) - , Search (i-1) - ] cr - ) - (Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w - -> ( ( f , g1) - , addImpulse [[AimAt ypos (2*aimtime)]] cr - ) - | dist cpos p > 10 - -> ( (f,g) , addImpulse [[PathTo p]] cr) - | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 - -> ( (f,g) - ,Just $ crTurnTowardSpeed 0.05 p' cr) - | otherwise -> ( (f,g) ,Just cr) - (InitGuard :_) -> ( (f,g) - ,replaceImpulse [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr - ) - (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ turnCloseSlow p cr) - | otherwise - -> ( (f,g) , replaceAction [AimAt p (i-1)] $ turnCloseSlow p cr) -sniperAI :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -sniperAI w (f,g) cr = - let cpos = _crPos cr - cid = _crID cr - ypos = _crPos $ you w - wp = _crInv cr IM.! _crInvSel cr - (aimtime,g1) = randomR (80,120) g - noAmmo = 0 == _wpLoadedAmmo wp - turnCloseSlow p | errorAngleVV 22 (p -.- cpos) - (unitVectorAtAngle (_crDir cr)) < 0.4 - = crTurnTowardSpeed 0.01 p - | otherwise = crTurnTowardSpeed 0.05 p - replaceImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ tail gs) - addImpulse newImpulses = Just . over (crState . goals) (\gs -> newImpulses ++ gs) - replaceAction newActions - = Just . over (crState . goals) (\((_:as):ass) -> (newActions ++ as):ass) - addAction newActions - = Just . over (crState . goals) (\(as:ass) -> (newActions++as):ass) --- autoFireTweak p | _wpIsAuto wp = Just --- | otherwise = replaceImpulse [[AimAt p (_itUseRate wp * 2)]] - in --if _crHP cr <= 0 then killCr w f cr else - case head $ _goals $ _crState cr of - [] | canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | otherwise -> ( ( f , g ) - , replaceImpulse [] cr - ) - (WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 ) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | x == 0 -> ( (f ,g ), replaceAction [] cr ) - | otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr ) - (MoveToFor p x:gls) - | canSeeFire cpos ypos w -> ( (f , g1) - , replaceImpulse [[AimAt ypos aimtime]] cr - ) - | x == 0 -> ( (f , g) - , replaceAction [] cr - ) - | dist p cpos < 1 -> ( (f , g) , replaceAction [] cr) - | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 - -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crTurnTowardSpeed 0.05 p cr ) - | otherwise -> ( (f , g) - , replaceAction [MoveToFor p (x-1)] $ crMvForward 2 - $ crTurnTowardSpeed 0.05 p cr ) - (PathTo p:_) | dist p cpos < 1 -> ( (f , g) , replaceAction [] cr ) - | hasLOS cpos p w -> ( (f , g) , addAction [MoveToFor p 100] cr ) - | otherwise -> case pointTowardsImpulse cpos p w of - Just q -> ( (f , g) , addAction [MoveToFor q 100] cr ) - _ -> ( (f , g) , replaceAction [] cr ) - (FireAt p:gls) | noAmmo -> ( (tryUseItem cid . f , g ) - , replaceImpulse [[Reload - ,WaitFor 50 - --,Search 1 ,WaitFor 100 - ]] - cr - ) - | canSeeFireVisionAll cid (_yourID w) w - -> ( (tryUseItem cid . f , g) - , replaceImpulse [[FireAt ypos]] $ turnCloseSlow p cr - ) - | pathToPointFireable cid p w - -> ( (tryUseItem cid . f , g) - , Just $ turnCloseSlow p cr - ) - | otherwise -> ( (f , g) - , replaceImpulse [[WaitFor 50 ]] cr - ) - (Reload:gls) | _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr ) - | canSeeFireVisionAny cid (_yourID w) w - -> ( (f , g) - , Just $ turnCloseSlow ypos cr - ) -- no longer chase if see you when reloading - -- $ replaceAction [] w - | otherwise -> ( (f , g) , Just cr) - (Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr) - | otherwise - -> ( ( f , g1) - , replaceAction [ PathTo (randomPointXStepsFrom 3 cpos w) - , Search (i-1) - ] cr - ) - (Guard p p':_) | canSeeFireVision cid (_yourID w) w - -> ( ( f , g1) - , addImpulse [[AimAt ypos (2*aimtime)]] cr - ) - | dist cpos p > 1 - -> ( (f,g) , addImpulse [[PathTo p]] cr) - | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 - -> ( (f,g) - ,Just $ crTurnTowardSpeed 0.05 p' cr) - | otherwise -> ( (f,g) ,Just cr) - (InitGuard :_) -> ( (f,g) - ,replaceImpulse [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] cr - ) - (AimAt p i:_) | i == 0 -> ( (f,g) , replaceAction [FireAt p] cr ) - | canSeeFireVision cid (_yourID w) w - -> ( (f,g) , replaceAction [AimAt ypos (i-1)] $ crTurnTowardSpeed 0.2 p cr) - | otherwise - -> ( (f,g) , replaceAction [AimAt p (i-1)] $ turnCloseSlow p cr) ---closeShooterAI :: Int -> World -> World ---closeShooterAI cid w = let cr = _creatures w IM.! cid --- cpos = _crPos cr --- ypos = _crPos $ you w --- wp = _crInv cr IM.! _crInvSel cr --- noAmmo = 0 == _wpLoadedAmmo wp --- turnCloseSlow p | errorAngleVV 22 (p -.- cpos) --- (unitVectorAtAngle (_crDir cr)) < 0.4 --- = turnTowardSpeed 0.01 p cid --- | otherwise = turnTowardSpeed 0.05 p cid --- replaceImpulse newImpulses = over (creatures . ix cid . crState . goals) --- (\gs -> newImpulses ++ tail gs) --- addImpulse newImpulses = over (creatures . ix cid . crState . goals) --- (\gs -> newImpulses ++ gs) --- replaceAction newActions = over (creatures . ix cid . crState . goals) --- (\((_:as):ass) -> (newActions ++ as):ass) --- addAction newActions = over (creatures . ix cid . crState . goals) --- (\(as:ass) -> (newActions++as):ass) --- autoFireTweak p | _wpIsAuto wp = id --- | otherwise = replaceImpulse [[AimAt p (_itUseRate wp * 2)]] --- in if _crHP cr <= 0 then killCr cid w else --- case head $ _goals $ _crState cr of --- [] | canSeeAny cid (_yourID w) w --- -> replaceImpulse [[AimAt ypos 50]] w --- | otherwise -> replaceImpulse [] w --- (WaitFor x:gls)| canSeeAny cid (_yourID w) w --- -> replaceImpulse [[AimAt ypos 50]] w --- | x == 0 -> replaceAction [] w --- | otherwise -> replaceAction [WaitFor (x-1)] w --- (MoveToFor p x:gls) --- | canSeeAny cid (_yourID w) w -> replaceImpulse [[AimAt ypos 50]] w --- | x == 0 || not (canSeePoint cid p w) -> replaceAction [] w --- | dist p cpos < 10 -> replaceAction [] w --- | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 --- -> replaceAction [MoveToFor p (x-1)] $ turnTowardSpeed 0.05 p cid w --- | otherwise -> replaceAction [MoveToFor p (x-1)] --- $ mvForward speed cid $ turnTowardSpeed 0.05 p cid w --- (PathTo p:_) | dist p cpos < 10 -> replaceAction [] w --- | canSeePoint cid p w -> addAction [MoveToFor p 100] w --- | otherwise -> case pointTowardsImpulse cpos p w of --- Just q -> addAction [MoveToFor q 100] w --- _ -> replaceAction [] w --- (MoveFire mp tp:gls) --- | noAmmo -> replaceImpulse [[Reload --- ,MoveFire mp tp --- ]] --- $ tryUseItem cid w --- | not $ canSeeAll cid (_yourID w) w -> replaceAction [PathTo tp,Search 1] w --- | dist cpos mp < 10 -> replaceAction [MoveFire ypos ypos] $ turnCloseSlow tp --- $ tryUseItem cid w --- | otherwise -> replaceAction [MoveFire mp ypos] --- $ turnCloseSlow tp $ strafeTo speed mp cid --- $ tryUseItem cid w --- (Reload:gls) | _wpReloadState wp == 0 -> replaceAction [] w --- | canSeeAny cid (_yourID w) w -> turnCloseSlow ypos --- $ replaceAction [Reload,MoveFire ypos ypos,Search 1] --- $ replaceAction [] w --- | otherwise -> w --- (Guard p p':_)| canSeeAny cid (_yourID w) w --- -> addImpulse [[AimAt ypos 50]] w --- | dist cpos p > 10 --- -> addImpulse [[PathTo p]] w --- | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8 --- -> turnTowardSpeed 0.05 p' cid w --- | otherwise -> w --- (InitGuard :_) -> replaceImpulse [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] w --- (AimAt p i:_) | i == 0 -> replaceAction [MoveFire p p] w --- | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4 --- -> replaceAction [AimAt p (i-1)] $ turnTowardSpeed 0.05 p cid w --- | canSeeAll cid (_yourID w) w --- -> replaceAction [AimAt ypos (i-1)] $ turnCloseSlow p --- $ strafeTo speed p cid w --- | otherwise --- -> replaceImpulse [[AimAt p (i-1),Search 1]] $ turnCloseSlow p --- $ strafeTo speed p cid w --- (Search i:gls) | i == 0 -> replaceAction [] w --- | otherwise -> replaceAction [PathTo (randomPointXStepsFrom 3 cpos w) --- ] $ over randGen (snd . next) w --- where speed = 2 - -strafeTo :: Float -> Point2 -> Int -> World -> World -strafeTo speed targPos cid w = over (creatures . ix cid . crPos) (+.+ q) w - where q = (*.*) (speed * equipFactor * wpFactor) - $ safeNormalizeV $ (targPos -.- _crPos cr) - equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid - cr = _creatures w IM.! cid - wpFactor = _itAimingSpeed (_crInv cr IM.! _crInvSel cr) - -randomGraphStep :: RandomGen g => Int -> Gr a b -> State g (Maybe Int) -randomGraphStep n g = - do let ns = neighbors g n - i <- state $ randomR (0,length ns - 1) - case ns of [] -> return Nothing - _ -> return $ Just $ ns !! i -randomGraphStepRestricted :: RandomGen g => Int -> [Int] -> Gr a b -> State g (Maybe Int) -randomGraphStepRestricted n notns g = - do let ns = neighbors g n \\ notns - i <- state $ randomR (0,length ns - 1) - case ns of [] -> return Nothing - _ -> return $ Just $ ns !! i - ----- continues a walk from a list of points, without repetitions ----- supposes that the list is non-empty -randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int] -randomGraphWalk (n:ns) g = - do next <- randomGraphStepRestricted n ns g - case next of Nothing -> return (n:ns) - Just n' -> randomGraphWalk (n':n:ns) g - -randomPointXStepsFrom :: Int -> Point2 -> World -> Point2 -randomPointXStepsFrom i p w = - let g = _pathGraph w - ns = labNodes g - mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns - in case mp of Nothing -> p - Just (n,_) -> fromJust $ lab g - (last $ take i - $ evalState (randomGraphWalk [n] g) - $ _randGen w) - -randomPointsXStepsFrom :: Int -> Point2 -> World -> [Point2] -randomPointsXStepsFrom i p w = - let g = _pathGraph w - ns = labNodes g - mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns - in case mp of Nothing -> [p] - Just (n,_) -> mapMaybe (lab g ) - (take i - $ evalState (randomGraphWalk [n] g) - $ _randGen w) - - -errorNormalizeVAI :: Point2 -> Point2 -errorNormalizeVAI (0,0) = error $ "problem with function: errorNormalizeVAI in DodgeAIs" -errorNormalizeVAI p = normalizeV p - -splitCritPict' :: Int -> Picture -splitCritPict' i = pictures $ (++) [color (greyN 0.1) $ circleSolid r,color green $ circLine r] $ concatMap (\p -> map (uncurry translate p) pic) $ take (2^(i-1)) rps - where pic = [color green $ circLine 6] - rps = fst $ runState ((sequence . repeat . randInCirc) (r-6)) $ mkStdGen 0 - r = sqrt ((fromIntegral i) * spCrRadFac) - -splitCritPict :: Float -> Picture -splitCritPict x = pictures [color (greyN 0.8) $ circleSolid x, color green $ circLine x] -splitCritCorpse :: Float -> Picture -splitCritCorpse x = color (greyN 0.2) $ circleSolid x -spCrRadFac = 8^2 - -<<<<<<< HEAD -======= -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 - ) - where strafeSpeed = _varMovementStrafeSpeedModifier w * equipFactor * (fromMaybe 1 $ yourItem w ^? itAimingSpeed) - speed = _varMovementSpeedModifier w * equipFactor - equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! 0 - -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/3 - = over crPos (+.+ (0.2 *.* mov)) --- $ set ( creatures . ix i . crDir) (argV mov) - $ set crDir mouseDir - $ set (crState . stance . carriage) (Boosting mov) - cr - | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving && isAiming - = set crDir mouseDir - $ set (crState . stance . carriage) Floating - cr - | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving - = over crPos (+.+ (0.2 *.* mov)) --- $ set ( creatures . ix i . crDir) (argV mov) - -- $ set ( creatures . ix i . crDir) mouseDir - $ over crDir (flip fromMaybe dir) - $ set (crState . stance . carriage) (Boosting mov) - cr - | (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isAiming - = set (crState . stance . carriage) Floating - $ set crDir mouseDir - cr - | any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr - = set (crState . stance . carriage) Floating - cr - | isAiming - = -- stopSoundFrom (CrSound i) $ - stepForward' aimSpeed - $ over crPos (+.+ (aimSpeed *.* mov)) - $ set crDir mouseDir - cr - | isMoving - = -- continueOrLoopFrom (CrSound i) twoStepSound $ - stepForward' speed - $ over ( crPos) (+.+ (speed *.* mov)) - $ over ( crDir) (flip fromMaybe dir) - cr - | otherwise - = -- stopSoundFrom (CrSound i) $ - over ( crDir) (flip fromMaybe dir) - cr - where (mov',dir') = wasdComp (view keys w) w - (mov,dir) = (rotateV (_cameraRot w) mov',fmap (_cameraRot w +) dir') - isMoving = mov' /= (0,0) - isAiming = (_posture $ _stance $ _crState cr) == Aiming - mouseDir = case w ^? creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) - . itAttachment of - Just (Just (ItScope {_scopePos = p})) -> normalizeAngle $ argV - $ p +.+ 2 / _cameraZoom w - *.* rotateV (_cameraRot w) (_mousePos w) - _ -> normalizeAngle $ argV (_mousePos w) + _cameraRot w - - -wasdM :: World -> SDL.Scancode -> Point2 -wasdM w scancode - | scancode == moveUpKey (_keyConfig w) = (0,1) - | scancode == moveDownKey (_keyConfig w) = (0,-1) - | scancode == moveRightKey (_keyConfig w) = (1,0) - | scancode == moveLeftKey (_keyConfig w) = (-1,0) -wasdM _ _ = (0,0) ---wasdM SDL.ScancodeW = (0,1) ---wasdM SDL.ScancodeS = (0,-1) ---wasdM SDL.ScancodeD = (1,0) ---wasdM SDL.ScancodeA = (-1,0) ---wasdM _ = (0,0) - -wasdComp :: S.Set SDL.Scancode -> World -> (Point2,Maybe Float) -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) ->>>>>>> testing - ----------------- -circLine x = line [(0,0),(x,0)] - -sigmoid x = x/sqrt(1+x^2) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 1be0ceed8..39507f215 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -45,9 +45,9 @@ midPadL i x xs ys = take j (xs ++ repeat x) ++ ys j = i - length ys takeUntil :: (a -> Bool) -> [a] -> [a] -takeUntil f ps = case span (not . f) ps of +takeUntil f ps = case break f ps of (xs,[]) -> xs - (xs,(y:_)) -> xs ++ [y] + (xs, y:_ ) -> xs ++ [y] you :: World -> Creature you w = _creatures w IM.! _yourID w @@ -63,7 +63,7 @@ crItem w cid = _crInv cr IM.! _crInvSel cr where cr = _creatures w IM.! cid -yourItemRef w = (creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))) +yourItemRef w = creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)) wallNormal :: Wall -> Point2 wallNormal wl = normalizeV . vNormal $ a -.- b @@ -73,22 +73,21 @@ wallNormal wl = normalizeV . vNormal $ a -.- b wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall] wallsOnLine p1 p2 ws = hitWalls where - hitPoint w = intersectSegSeg' p1 p2 (fst $ _wlLine w) (snd $ _wlLine w) + hitPoint w = uncurry (intersectSegSeg' p1 p2) (_wlLine w) hitWalls = filter (isJust . hitPoint) (IM.elems ws) wallOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Wall wallOnLine p1 p2 ws = listToMaybe $ sortBy f hitWalls where - hitPoint w = intersectSegSeg' p1 p2 (fst $ _wlLine w) (snd $ _wlLine w) + hitPoint w = uncurry (intersectSegSeg' p1 p2) (_wlLine w) hitWalls = filter (isJust . hitPoint) (IM.elems ws) f w1 w2 = compare (magV (p1 -.- fromJust (hitPoint w1))) (magV (p1 -.- fromJust (hitPoint w2))) -wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> [Wall] -wallsOnCirc p r wls = IM.elems $ IM.filter f wls +wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> IM.IntMap Wall +wallsOnCirc p r = IM.filter f where - f wl = circOnSeg (fst $ _wlLine wl) (snd $ _wlLine wl) p r - + f wl = uncurry circOnSeg (_wlLine wl) p r allWalls :: World -> IM.IntMap Wall allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _wallsZone w @@ -288,7 +287,7 @@ collidePointWallsNorm p1 p2 ws = listToMaybe . sortOn f . IM.elems - $ IM.mapMaybe (( \(x,y) -> intersectSegSeg' p1 p2 x y <&> (, vNormal $ x -.- y ) ) + $ IM.mapMaybe (( \(x,y) -> intersectSegSeg' p1 p2 x y <&> ( , vNormal $ x -.- y ) ) . _wlLine) ws where f (a,_) = magV (p1 -.- a) @@ -301,7 +300,7 @@ collidePointWallsCol p1 p2 ws . sortOn f . IM.elems $ IM.mapMaybe ( (\(m, c) -> m <&> (, c)) - . (\w -> (intersectSegSeg' p1 p2 (fst $ _wlLine w) (snd $ _wlLine w), _wlColor w))) ws + . (\w -> (uncurry (intersectSegSeg' p1 p2) (_wlLine w), _wlColor w))) ws where f (a,_) = magV (p1 -.- a) {- | Looks for first collision of a point with walls. @@ -507,3 +506,11 @@ isAnimate cr = case _crActionPlan cr of _ -> True sigmoid x = x/sqrt(1+x^2) + +{- | In order to force a list, apply with seq. -} +forceSpine :: [a] -> () +forceSpine = foldr (const id) () + +forceList :: [a] -> [a] +forceList l = seq (forceSpine l) l + diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 4f0cf655c..cd47c8344 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -13,9 +13,7 @@ import Control.Lens hasLOS :: Point2 -> Point2 -> World -> Bool {-# INLINE hasLOS #-} -hasLOS p1 p2 w = (not $ pointHitsWalls p1 p2 nearbyWalls) - where - nearbyWalls = wallsAlongLine p1 p2 w +hasLOS p1 p2 w = not $ pointHitsWalls p1 p2 $ wallsAlongLine p1 p2 w -- | looks for first collision of a point with walls -- if found, gives point and reflection velocity reflectPointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2) @@ -56,11 +54,11 @@ reflectPointWallsDamped dfact p1 p2 ws -- | Test if a point collides with walls pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool pointHitsWalls p1 p2 - = any $ isJust . ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine + = any $ isJust . uncurry (intersectSegSeg' p1 p2) . _wlLine -- | Test if there something blocking a walk collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool collidePointWalkable p1 p2 ws - = any (isJust . ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine) + = any (isJust . uncurry (intersectSegSeg' p1 p2) . _wlLine) $ IM.filter (fromMaybe True . (^? doorPathable)) ws furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2 @@ -69,7 +67,7 @@ furthestPointWalkable p1 p2 ws . listToMaybe . sortOn (dist p1) . IM.elems - $ IM.mapMaybe ( ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws + $ IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine) ws collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 {-# INLINE collidePointIndirect #-} @@ -77,7 +75,7 @@ collidePointIndirect p1 p2 ws = listToMaybe . sortOn (dist p1) . IM.elems - . IM.mapMaybe ( ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine) + . IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine) $ IM.filter (not . _wlIsSeeThrough) ws {- | Checks to see whether someone can fire bullets effectively between two points. - Not sure if this needs vision as well, need to make this uniform. -} @@ -86,13 +84,13 @@ collidePointFire p1 p2 ws = listToMaybe . sortOn (dist p1) . IM.elems - . IM.mapMaybe ( ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine ) + . IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine ) $ IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))) ws {- | Checks to see whether someone can fire bullets effectively between two points. - Not sure if this needs vision as well, need to make this uniform. -} collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool collidePointFireVision p1 p2 ws - = any ( isJust . ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine) + = any ( isJust . uncurry (intersectSegSeg' p1 p2) . _wlLine) $ IM.filter notBlockWindow ws where notBlockWindow wl = case wl ^? blHP of @@ -125,15 +123,14 @@ canSeePoint i p w = hasLOS p1 p w pathToPointFireable :: Int -> Point2 -> World -> Bool pathToPointFireable i p w = not - . pointHitsWalls (_crPos (_creatures w IM.! i)) p - $ IM.filter (not . isJust . \wl -> wl ^? blHP) $ wallsAlongLine p1 p w + . pointHitsWalls (_crPos $ _creatures w IM.! i) p + $ IM.filter (isNothing . (^? blHP) ) $ wallsAlongLine p1 p w where p1 = _crPos (_creatures w IM.! i) canSeePointAll :: Int -> Point2 -> World -> Bool canSeePointAll i targPos w - = and - $ map (flip (canSeePoint i) w . (\p -> (targPos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)] + = all (flip (canSeePoint i) w . (\p -> targPos +.+ radius *.* p)) [(1,0),(0,1),(-1,0),(0,-1)] where cr = _creatures w IM.! i cpos = _crPos cr @@ -141,8 +138,7 @@ canSeePointAll i targPos w canSeeAny :: Int -> Int -> World -> Bool canSeeAny fromID toID w - = or - $ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)] + = any (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p)) [(1,0),(0,1),(-1,0),(0,-1)] where cr = _creatures w IM.! toID cpos = _crPos cr @@ -150,8 +146,7 @@ canSeeAny fromID toID w canSeeAll :: Int -> Int -> World -> Bool canSeeAll fromID toID w - = and - $ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)] + = all (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p)) [(1,0),(0,1),(-1,0),(0,-1)] where cr = _creatures w IM.! toID cpos = _crPos cr @@ -164,7 +159,7 @@ canWalk i j w = not $ collidePointWalkable ipos jpos $ wallsAlongLine ipos jpos jpos = _crPos (_creatures w IM.! j) canSeeIndirect :: Int -> Int -> World -> Bool -canSeeIndirect i j w = not . isJust . collidePointIndirect ipos jpos $ wallsAlongLine ipos jpos w +canSeeIndirect i j w = isNothing . collidePointIndirect ipos jpos $ wallsAlongLine ipos jpos w where ipos = _crPos (_creatures w IM.! i) jpos = _crPos (_creatures w IM.! j) diff --git a/src/Dodge/Config/KeyConfig.hs b/src/Dodge/Config/KeyConfig.hs index 989235c3c..6b8736a4b 100644 --- a/src/Dodge/Config/KeyConfig.hs +++ b/src/Dodge/Config/KeyConfig.hs @@ -7,7 +7,7 @@ import Foreign.C.Types import GHC.Generics import qualified GHC.Int import qualified SDL -import SDL.Internal.Numbered as SDL.Internal.Numbered +import qualified SDL.Internal.Numbered import System.Directory diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 41487b612..e584cb71d 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -9,10 +9,8 @@ module Dodge.Creature where 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.Creature.AlertLevel import Dodge.Creature.SetTarget import Dodge.Creature.Test @@ -21,7 +19,6 @@ import Dodge.Creature.PistolCrit import Dodge.Creature.LtAutoCrit import Dodge.Creature.SpreadGunCrit import Dodge.Data -import Dodge.AIs import Dodge.Default import Dodge.Base import Dodge.Item.Weapon @@ -35,7 +32,6 @@ import Dodge.Creature.Rationality import Dodge.Creature.ChooseTarget import Dodge.Item import Dodge.Picture.Layer -import Dodge.Creature.Picture import Picture import Geometry @@ -63,7 +59,6 @@ spawnerCrit = defaultCreature { --_crUpdate = stateUpdate $ spawnerAI chaseCrit _crHP = 300 , _crPict = basicCrPict blue - , _crState = defaultState {_goals = [[WaitFor 0]] } , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] } smallChaseCrit :: Creature @@ -78,10 +73,11 @@ smallChaseCrit = defaultCreature } chaseCrit :: Creature chaseCrit = defaultCreature - { _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs - [ chaseTarget targetYouLOS - , \ _ -> crMeleeCooldown . _Just %~ (max 0 . subtract 1) - ] + { _crUpdate = stateUpdate $ impulsiveAIR $ + chaseTargetR targetYouLOS <=< + overrideMeleeCloseTargetR <=< + basicPerceptionUpdateR [0] <=< + return . (crMeleeCooldown . _Just %~ (max 0 . subtract 1)) , _crHP = 300 , _crPict = basicCrPict green , _crInv = IM.empty @@ -93,7 +89,6 @@ armourChaseCrit = defaultCreature { _crUpdate = stateUpdate $ meleeCooldown $ impulsiveAI $ chaseTarget targetYouLOS , _crHP = 300 , _crPict = basicCrPict green - , _crState = defaultState {_goals = [[Wait]]} , _crInv = IM.fromList [(0,frontArmour) ,(1,medkit 200) @@ -139,7 +134,6 @@ longCrit = defaultCreature , _crInv = IM.fromList [(0,longGun),(1,medkit 100)] , _crInvSel = 0 , _crRad = 10 - , _crState = defaultState {_goals = [[InitGuard]]} , _crHP = 300 } multGunCrit :: Creature @@ -149,7 +143,6 @@ multGunCrit = defaultCreature , _crInv = IM.fromList [(0,multGun),(1,medkit 100)] , _crInvSel = 0 , _crRad = 10 - , _crState = defaultState {_goals = [[InitGuard]]} , _crHP = 300 , _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs [ performActions @@ -197,68 +190,21 @@ autoCrit = defaultCreature , _crInv = IM.fromList [(0,autoGun),(1,medkit 100)] , _crInvSel = 0 , _crRad = 10 - , _crState = defaultState {_goals = [[InitGuard]]} , _crHP = 300 } addArmour :: Creature -> Creature addArmour = over crInv insarmour where insarmour xs = IM.insert (newKey xs) frontArmour xs - ---packCrits :: (Int -> World -> World) -> [Int] -> [Creature] ---packCrits ai is = [(defaultCreature i) --- { _crPos = (150,10+20*fromIntegral i) --- , _crPict = swarmPict --- , _crUpdate = ai i --- --, _crUpdate = swarmAI is i --- , _crRad = 3 --- , _crHP = 1 --- , _crMass = 2 --- } --- | i <- is] - ---queenBeeCrit :: Int -> Creature ---queenBeeCrit cID = (defaultCreature cID) --- { _crRad = 20 --- , _crCorpse = color (greyN 0.5) $ circleSolid 20 --- , _crPict = const $ pictures [color black $ circSolid 20 --- ,color yellow $ circLine 20 --- ] --- , _crUpdate = checkDead cID . makeStateAI queenBeeAI cID --- , _crState = QueenBee 0 20 --- , _crMass = 20 --- } - ---antCrit :: Int -> Creature ---antCrit cID = (defaultCreature cID) --- { _crPos = (0,100 + 3 * fromIntegral cID) --- , _crUpdate = checkDead cID . makeStateAI (antAI 2) cID --- , _crState = AntMove 50 --- , _crPict = antPic --- , _crRad = 3 --- , _crHP = 1 --- , _crMass = 2 --- , _crCorpse = color (greyN 0.5) $ circSolid 3 --- } --- where i = evalState (state (randomR (1::Int,100))) (mkStdGen cID) ---antPic = const $ pictures [ translate (-1) 0 $ circleSolid 2 --- , translate (2) 0 $ circleSolid 1 --- , translate (1) 0 $ circleSolid 1 --- , line [(3,3),(-3,-3)] --- , line [(-3,3),(3,-3)] --- , line [(0,-3),(0,3)] --- ] -{- | -The creature you control. -ID 0. --} +{- | The creature you control. +ID 0. -} startCr :: Creature startCr = defaultCreature { _crPos = (0,0) , _crOldPos = (0,0) , _crDir = 0 , _crID = 0 - , _crPict = basicCrPict $ black + , _crPict = basicCrPict black , _crUpdate = stateUpdate yourControl , _crRad = 10 , _crMass = 10 @@ -268,9 +214,7 @@ startCr = defaultCreature , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10] , _crFaction = PlayerFaction } -{- | -Items you start with. - -} +{- | Items you start with. -} startInventory = IM.fromList (zip [0..20] ( [bezierGun @@ -298,5 +242,5 @@ startInventory = IM.fromList (zip [0..20] ++ repeat NoItem)) -smokeGenGun = effectGun "smoke" $ \_ -> spawnSmokeAtCursor +smokeGenGun = effectGun "smoke" $ const spawnSmokeAtCursor diff --git a/src/Dodge/Creature/AI.hs b/src/Dodge/Creature/AI.hs deleted file mode 100644 index 093cb0e60..000000000 --- a/src/Dodge/Creature/AI.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Dodge.Creature.AI - where -import Dodge.Data - -import Control.Lens -import System.Random - -insectAI - :: ( World -> StdGen -> Creature -> (World -> World, StdGen, Creature) ) - -> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -insectAI = undefined diff --git a/src/Dodge/Creature/AI/Data.hs b/src/Dodge/Creature/AI/Data.hs deleted file mode 100644 index 759d548db..000000000 --- a/src/Dodge/Creature/AI/Data.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -module Dodge.Creature.AI.Data - where -import Dodge.Creature.State.Data -import Dodge.Creature.Impulse.Data - -import Control.Lens -data Intelligence - = Zombie { _crImpulse :: Impulse } - | Inanimate - diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index 0ff722c80..3fa07cf05 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -1,6 +1,5 @@ {- | Actions performed by creatures within the world -} -{-# LANGUAGE BangPatterns #-} module Dodge.Creature.Action ( module Dodge.Creature.Action , module Dodge.Creature.Action.UseItem @@ -36,9 +35,9 @@ crStrafeLeft -> Creature crStrafeLeft speed cr = advanceStepCounter s2 $ over crPos (+.+ p) cr where - p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr + pi/2) + p = s2 *.* unitVectorAtAngle (_crDir cr + pi/2) equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr - s2 = (speed * equipFactor) + s2 = speed * equipFactor crStrafeRight :: Float -- ^ Speed @@ -46,9 +45,9 @@ crStrafeRight -> Creature crStrafeRight speed cr = advanceStepCounter s2 $ over crPos (+.+ p) cr where - p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr - pi/2) + p = s2 *.* unitVectorAtAngle (_crDir cr - pi/2) equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr - s2 = (speed * equipFactor) + s2 = speed * equipFactor turnTo :: Point2 -- ^ Target point @@ -239,7 +238,7 @@ blinkAction n w cp = _crPos $ _creatures w IM.! n p2 = reflectPointWalls cp p1 $ wallsAlongLine cp p1 w r = 1.5 * _crRad (_creatures w IM.! n) - p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2) + p3 = maybe p1 ((\p -> moveAmountToward p r cp) . fst) p2 blinkShockwave :: Int -- ^ Blinking creature ID. @@ -317,7 +316,6 @@ pickUpItem cid flit w = case maybeInvSlot of updateItLocation invid w' = case _itID it of Nothing -> w' Just j -> w' & itemPositions . ix j .~ InInv 0 invid - {- | 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. -} @@ -329,25 +327,24 @@ 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 + 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 - +crMvForward speed = crMvBy (speed,0) advanceStepCounter :: Float -- ^ Speed -> Creature -> Creature -advanceStepCounter speed cr = over (crStance . carriage) f cr +advanceStepCounter speed = crStance . carriage %~ f where - f (w@Walking {}) = w {_stepToAdd = ceiling speed} + f w@Walking{} = w{_stepToAdd = ceiling speed} f s = s creatureTurn :: Float -> Creature -> Creature diff --git a/src/Dodge/Creature/Action/Movement.hs b/src/Dodge/Creature/Action/Movement.hs index 67ca6bd10..9aa5276d4 100644 --- a/src/Dodge/Creature/Action/Movement.hs +++ b/src/Dodge/Creature/Action/Movement.hs @@ -9,7 +9,7 @@ import Control.Lens strafeTo :: Float -> Point2 -> Int -> World -> World strafeTo speed targPos cid w = over (creatures . ix cid . crPos) (+.+ q) w where q = (*.*) (speed * equipFactor * wpFactor) - $ safeNormalizeV $ (targPos -.- _crPos cr) + $ safeNormalizeV $ targPos -.- _crPos cr equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid cr = _creatures w IM.! cid wpFactor = _itAimingSpeed (_crInv cr IM.! _crInvSel cr) diff --git a/src/Dodge/Creature/Action/UseItem.hs b/src/Dodge/Creature/Action/UseItem.hs index 332ba441b..bef66e75a 100644 --- a/src/Dodge/Creature/Action/UseItem.hs +++ b/src/Dodge/Creature/Action/UseItem.hs @@ -7,10 +7,13 @@ import Dodge.Inventory import qualified Data.IntMap as IM import Control.Lens -import Data.Maybe (fromMaybe) +import Data.Maybe (maybe) useItem :: Int -> World -> World -useItem n w = equippedItemEffect n w +useItem n w = itemEffect n it w + where + c = _creatures w IM.! n + it = _crInv c IM.! _crInvSel c crUseItem :: Creature -> World -> World --crUseItem cr = itemEffect (_crID cr) (_crInv cr IM.! _crInvSel cr) @@ -24,18 +27,12 @@ tryUseItem cid w = case w ^? creatures . ix cid of Just cr -> itemEffect cid (_crInv cr IM.! _crInvSel cr) w Nothing -> w -equippedItemEffect :: Int -> World -> World -equippedItemEffect n w = itemEffect n it w - where - c = _creatures w IM.! n - it = _crInv c IM.! _crInvSel c - itemEffect :: Int -- ^ Creature id (I am almost certain) -> Item -> World -> World -itemEffect n (Consumable {_cnEffect=eff }) w = fromMaybe w $ rmSelectedInvItem n <$> eff n w -itemEffect n (Weapon {_wpFire=eff}) w = eff n w -itemEffect n (Throwable {_twFire = eff}) w = eff n w +itemEffect n Consumable{_cnEffect=eff } w = maybe w (rmSelectedInvItem n) (eff n w) +itemEffect n Weapon{_wpFire=eff} w = eff n w +itemEffect n Throwable{_twFire = eff} w = eff n w itemEffect _ _ w = w diff --git a/src/Dodge/Creature/ActionRat.hs b/src/Dodge/Creature/ActionRat.hs index 1ee4c8ce7..4a6121382 100644 --- a/src/Dodge/Creature/ActionRat.hs +++ b/src/Dodge/Creature/ActionRat.hs @@ -20,7 +20,6 @@ import Dodge.Data import Dodge.Base import Dodge.Base.Collide import Dodge.Creature.ChooseTarget -import Dodge.Creature.Rationality.Data import Dodge.Creature.Stance.Data import Dodge.Creature.Test import Geometry @@ -216,7 +215,7 @@ applyNewStrategies applyNewStrategies w cr = case cr ^? crActionPlan . crStrategy of Just (StrategyActions strat acs) -> cr & crActionPlan . crAction .~ acs & crActionPlan . crStrategy .~ strat - otherwise -> cr + _ -> cr doStrategyActions :: World @@ -225,7 +224,7 @@ doStrategyActions doStrategyActions w cr = case cr ^? crActionPlan . crStrategy of Just (StrategyActions strat acs) -> cr & crActionPlan . crAction .~ acs & crActionPlan . crStrategy .~ strat - otherwise -> cr + _ -> cr updateShoot :: World @@ -270,7 +269,7 @@ watchUpdateStrat -> Creature watchUpdateStrat fs w cr = case cr ^? crActionPlan . crStrategy of Just WatchAndWait -> cr - & crActionPlan . crStrategy .~ listGuard (fs, (\_ _ -> WatchAndWait)) (w, cr) w cr + & crActionPlan . crStrategy .~ listGuard (fs, \_ _ -> WatchAndWait) (w, cr) w cr _ -> cr listGuard :: ([(a -> Bool, b)] , b) -> a -> b diff --git a/src/Dodge/Creature/AlertLevel.hs b/src/Dodge/Creature/AlertLevel.hs index ca845bf56..9821cd622 100644 --- a/src/Dodge/Creature/AlertLevel.hs +++ b/src/Dodge/Creature/AlertLevel.hs @@ -3,11 +3,12 @@ module Dodge.Creature.AlertLevel where import Dodge.Data import Dodge.Creature.AlertLevel.Data -import Dodge.Base.Collide +import Dodge.Base +--import Dodge.Base.Collide import Control.Lens +import Control.Monad.Reader import qualified Data.IntMap.Strict as IM - {- | Ties together (currently) an awareness and attention update -} basicPerceptionUpdate :: [Int] -- ^ List of creature ids that may direct attention and awareness @@ -15,13 +16,20 @@ basicPerceptionUpdate -> Creature -> Creature basicPerceptionUpdate is w cr - = basicAwarenessUpdate w $ - basicAttentionUpdate is w cr + = basicAwarenessUpdate w $ basicAttentionUpdate is w cr + +basicPerceptionUpdateR + :: [Int] -- ^ List of creature ids that may direct attention and awareness + -> Creature + -> Reader World Creature +basicPerceptionUpdateR is cr = reader $ \w -> + basicAwarenessUpdate w $ basicAttentionUpdate is w cr + {- | Update a creatures awareness based upon the creatures current direction of attention -} basicAwarenessUpdate :: World -> Creature -> Creature -basicAwarenessUpdate w cr = case _crAttentionDir cr of +basicAwarenessUpdate _ cr = case _crAttentionDir cr of AttentiveTo is -> cr & crAwarenessLevel %~ updateAwareness is Fixated i -> cr & crAwarenessLevel %~ ( IM.insert i (Cognizant 100) . IM.mapMaybe decreaseAwareness) @@ -54,4 +62,4 @@ basicAttentionUpdate -> Creature -> Creature basicAttentionUpdate cids w cr = cr & crAttentionDir .~ - AttentiveTo (filter (\cid -> canSee (_crID cr) cid w) cids) + AttentiveTo (forceList $ filter (\cid -> canSee (_crID cr) cid w) cids) diff --git a/src/Dodge/Creature/AlertLevel/Data.hs b/src/Dodge/Creature/AlertLevel/Data.hs index 5beb0f9ba..a181e9892 100644 --- a/src/Dodge/Creature/AlertLevel/Data.hs +++ b/src/Dodge/Creature/AlertLevel/Data.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StrictData #-} module Dodge.Creature.AlertLevel.Data where +import Control.Lens data AwakeLevel = Comatose @@ -9,9 +12,11 @@ data AwakeLevel | Overstrung data AttentionDir - = AttentiveTo [Int] - | Fixated Int + = AttentiveTo {_unAttentiveTo :: [Int]} + | Fixated {_unFixated :: Int } data AwarenessLevel = AwarenessInt Int | Cognizant Int + +makeLenses ''AttentionDir diff --git a/src/Dodge/Creature/Data.hs b/src/Dodge/Creature/Data.hs deleted file mode 100644 index 98683c024..000000000 --- a/src/Dodge/Creature/Data.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -module Dodge.Creature.Data - where -import Control.Lens diff --git a/src/Dodge/Creature/Impulse/Data.hs b/src/Dodge/Creature/Impulse/Data.hs deleted file mode 100644 index 00ef51258..000000000 --- a/src/Dodge/Creature/Impulse/Data.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -module Dodge.Creature.Impulse.Data - where -import Dodge.Creature.Stance.Data -import Geometry.Data - -import Control.Lens -data Impulse - = MoveTo Point2 - | MoveToFor Point2 Int - | MoveFire Point2 Point2 - | PathTo Point2 - | PathAlong [Point2] - | SubPathTo Point2 Int Point2 - | Wait - | WaitFor Int - | WaitForID Int Int - | FireAt Point2 - | FireAtID Int Point2 - | Fire - | Reload - | IncreaseAlert Int - | Guard Point2 Point2 - | Search Int - | SearchNear Point2 - | AimAt Point2 Int - | InitGuard - | Init - | MeleeAttack Int - | InitTrackYou - | TrackYou - | Track Int - | TrackFor Int Int - | TurnByFor Float Int - | TurnTo Point2 - | TurnToward Point2 - | TurnTowardAngle Float - | StrafeLeftAround Int Point2 - | StrafeRightAround Int Point2 - | StrafeLeftFor Int - | StrafeRightFor Int - | StrafeLeftForSpeed Int Float - | StrafeRightForSpeed Int Float - | StrafeLeftFire - | StrafeRightFire - | MoveForwardFor Int - | MoveForwardFire - | MoveBackwardFor Int - | MoveByFor Point2 Int - | MoveBackwardFire - | ImpulseID Int Impulse - | AtRange Float - | AtRanges Float Float - | RepeatAction Int Impulse - | MakeJudgement - | SetPosture Posture - deriving (Eq,Show) diff --git a/src/Dodge/Creature/ImpulseRat.hs b/src/Dodge/Creature/ImpulseRat.hs index 724f2d24c..90307c65c 100644 --- a/src/Dodge/Creature/ImpulseRat.hs +++ b/src/Dodge/Creature/ImpulseRat.hs @@ -4,23 +4,22 @@ import Dodge.Data import Dodge.Base import Dodge.Creature.ChooseTarget import Dodge.Creature.State.Data -import Dodge.Creature.Rationality.Data import Geometry import qualified Data.IntMap as IM import Control.Lens +import Control.Monad.Reader encircle :: Creature -> IM.IntMap Creature -> Creature -> Point2 encircle tcr crs cr | length crs <= 1 = ypos - | otherwise = ypos +.+ f (max 0 (magV (ypos -.- cenp) - 30) ) *.* safeNormalizeV (cpos -.- cenp) + | otherwise = ypos +.+ f (max 0 (magV (ypos -.- cenp) - 80) ) *.* safeNormalizeV (cpos -.- cenp) where cpos = _crPos cr ypos = _crPos tcr f x = 150 * sigmoid (x-10) cenp = (1 / fromIntegral (length crs)) *.* foldr1 (+.+) (map _crPos $ IM.elems crs) - lineOrth :: Creature -> IM.IntMap Creature -> Creature -> Point2 lineOrth tcr crs cr = p where @@ -64,6 +63,19 @@ spreadOut ycr crs cr = p | dist ypos cpos > 90 = 1 | otherwise = 1.5 +swarmUsingCenter + :: (Creature -> Point2 -> Creature -> Creature) + -> (Point2 -> Creature -> Creature) + -> World + -> Creature + -> Creature +swarmUsingCenter updT upd w cr = case _crTarget cr of + Nothing -> upd cenp cr + Just tcr -> updT tcr cenp cr + where + cid = _crID cr + cenp = _crGroupCenter $ _creatureGroups w IM.! (_crGroupID $ _crGroup $ _creatures w IM.! cid) + flockChaseTarget :: (Creature -> IM.IntMap Creature -> Creature -> Creature) -- ^ Update with target -> (IM.IntMap Creature -> Creature -> Creature) -- ^ Update without target @@ -100,17 +112,52 @@ chaseTarget targFunc w cr = case targFunc cr w of Nothing -> cr Just crTarg -> cr & crActionPlan . crImpulse .~ chaseTarg cr crTarg +chaseTargetR + :: (Creature -> World -> Maybe Creature) -- ^ Function for determining target + -> Creature + -> Reader World Creature +chaseTargetR targFunc cr = reader $ \w -> case targFunc cr w of + Nothing -> cr + Just crTarg -> cr & crActionPlan . crImpulse .~ chaseTarg cr crTarg + + +overrideMeleeCloseTarget :: World -> Creature -> Creature +overrideMeleeCloseTarget w cr = case _crTarget cr of + Nothing -> cr + Just tcr + | _crMeleeCooldown cr == Just 0 + && dist (_crPos tcr) cpos < _crRad cr + _crRad tcr + 5 + && abs (_crDir cr - argV (_crPos tcr -.- cpos)) < pi/4 + -> cr & crActionPlan . crStrategy .~ StrategyActions MeleeStrike [DoImpulses [Melee (_crID tcr)]] + | otherwise -> cr + where + cpos = _crPos cr + +overrideMeleeCloseTargetR + :: Creature + -> Reader World Creature +overrideMeleeCloseTargetR cr = reader $ \w -> case _crTarget cr of + Nothing -> cr + Just tcr + | _crMeleeCooldown cr == Just 0 + && dist (_crPos tcr) cpos < _crRad cr + _crRad tcr + 5 + && abs (_crDir cr - argV (_crPos tcr -.- cpos)) < pi/4 + -> cr & crActionPlan . crStrategy .~ StrategyActions MeleeStrike [DoImpulses [Melee (_crID tcr)]] + | otherwise -> cr + where + cpos = _crPos cr + chaseTarg' :: Point2 -> Creature -> Creature -> [Impulse] chaseTarg' p cr crT | dist tpos cpos < combinedRad + 5 - && abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4 + && 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 + && abs (_crDir cr - argV (tpos -.- cpos)) < pi/4 = [ TurnToward tpos 0.05 ] - | abs ((_crDir cr) - argV (p -.- cpos)) < pi/4 - = [MoveForward 2.5 , TurnToward p 0.2, RandomTurn 0.2 ] + | abs (_crDir cr - argV (p -.- cpos)) < pi/4 + = [MoveForward 2.5 , TurnToward p 0.2 , RandomTurn 0.2 ] | otherwise = [MoveForward 2.5 , TurnToward p 0.05, RandomTurn 0.2 ] where cpos = _crPos cr @@ -120,13 +167,9 @@ chaseTarg' p cr crT 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)] - | dist tpos cpos < combinedRad + 5 - && abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4 + && abs (_crDir cr - argV (tpos -.- cpos)) < pi/4 = [ TurnToward tpos 0.05 ] - | abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4 + | 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 @@ -146,13 +189,13 @@ impulseShootAtTarget targFunc w cr = case targFunc cr w of impulseShootAtTarg :: Creature -> Creature -> [Impulse] impulseShootAtTarg cr crT | dist tpos cpos < combinedRad + 5 - && abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4 + && 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 + && abs (_crDir cr - argV (tpos -.- cpos)) < pi/4 = [ TurnToward tpos 0.05 ] - | abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4 + | 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 diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index 4dca5f528..452f35c5f 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/src/Dodge/Creature/Inanimate.hs @@ -6,7 +6,6 @@ module Dodge.Creature.Inanimate import Dodge.Data import Dodge.Creature.Stance.Data import Dodge.Creature.State.Data -import Dodge.Creature.Impulse.Data import Dodge.Base import Dodge.Picture.Layer import Dodge.Default @@ -59,8 +58,7 @@ barrel = defaultInanimate , color (greyN 0.5) $ circleSolid 8 ] , _crState = defaultState - {_goals = [[Wait]] - ,_crSpState = Barrel [] + {_crSpState = Barrel [] } , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] } @@ -74,8 +72,7 @@ explosiveBarrel = defaultInanimate , color orange $ circleSolid 10 ] , _crState = defaultState - {_goals = [[Wait]] - ,_crSpState = Barrel [] + {_crSpState = Barrel [] } , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] ,_crApplyDamage = \_ c -> (id, c) diff --git a/src/Dodge/Creature/LauncherCrit.hs b/src/Dodge/Creature/LauncherCrit.hs index 7fd8396ec..8c08f05ac 100644 --- a/src/Dodge/Creature/LauncherCrit.hs +++ b/src/Dodge/Creature/LauncherCrit.hs @@ -52,7 +52,7 @@ launcherCrit = defaultCreature } retreatFire :: Action -retreatFire = ImpulsesList ( [ [ UseItem ] ] ++ replicate 20 [ Turn 0.16 ]) +retreatFire = ImpulsesList ( [ UseItem ] : replicate 20 [ Turn 0.16 ]) `DoActionThen` HolsterWeapon `DoActionThen` @@ -60,7 +60,7 @@ retreatFire = ImpulsesList ( [ [ UseItem ] ] ++ replicate 20 [ Turn 0.16 ]) `DoActionThen` DrawWeapon `DoActionThen` - ImpulsesList ( [[UseItem]] ++ replicate 20 [ Turn $ negate 0.16 ] ) + ImpulsesList ( [UseItem] : replicate 20 [ Turn $ negate 0.16 ] ) `DoActionThen` HolsterWeapon `DoActionThen` diff --git a/src/Dodge/Creature/LtAutoCrit.hs b/src/Dodge/Creature/LtAutoCrit.hs index 17782a3f6..a66eb87be 100644 --- a/src/Dodge/Creature/LtAutoCrit.hs +++ b/src/Dodge/Creature/LtAutoCrit.hs @@ -72,4 +72,4 @@ chooseMovement cr w tcr = _creatures w IM.! 0 p = _crPos tcr v = vNormal $ p -.- cpos - p' = p +.+ 0.5 *.* (v -.- 20 *.* (normalizeV v)) + p' = p +.+ 0.5 *.* (v -.- 20 *.* normalizeV v) diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index a0f120bd3..f356a20a2 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -33,17 +33,17 @@ basicCrPict col cr = pictures | 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 + pdam = sum $ concatMap (map _dmAmount) pastDams col' = light . light . light $ light col bluntDam :: Maybe Point2 bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo) bluntScale = case fmap argV bluntDam of Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a) _ -> id - isBluntDam (Blunt {}) = True + isBluntDam Blunt{} = True isBluntDam _ = False piercingDam = find isPiercingDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo) - isPiercingDam (Piercing {}) = True + isPiercingDam Piercing{} = True isPiercingDam _ = False piercingMod = case fmap argV piercingDam of Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a) diff --git a/src/Dodge/Creature/PistolCrit.hs b/src/Dodge/Creature/PistolCrit.hs index 48ad4ad64..819365f87 100644 --- a/src/Dodge/Creature/PistolCrit.hs +++ b/src/Dodge/Creature/PistolCrit.hs @@ -93,8 +93,8 @@ chooseMovement' cr w = takeOneWeighted [chargeProb,retreatProb,strafeProb,strafe 3 `DoReplicate` ImpulsesList (replicate 9 [Move (0,-3)] ++ [[Move (0,-3),UseItem]]) - yposl = ypos -.- 100 *.* (vNormal $ normalizeV $ ypos -.- cpos) - yposr = ypos +.+ 100 *.* (vNormal $ normalizeV $ ypos -.- cpos) + yposl = ypos -.- 100 *.* vNormal (normalizeV $ ypos -.- cpos) + yposr = ypos +.+ 100 *.* vNormal (normalizeV $ ypos -.- cpos) retreatActions :: Creature -> Creature -> Action retreatActions tcr cr = diff --git a/src/Dodge/Creature/Rationality.hs b/src/Dodge/Creature/Rationality.hs index b4411ddbb..b6e370ad8 100644 --- a/src/Dodge/Creature/Rationality.hs +++ b/src/Dodge/Creature/Rationality.hs @@ -2,7 +2,6 @@ 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 @@ -14,6 +13,7 @@ import Data.Maybe import qualified Data.IntMap.Strict as IM import System.Random import Control.Lens +import Control.Monad.Reader -- Alternatives would probably be a very good fit for actions... @@ -24,6 +24,14 @@ composeInternalAIs -> Creature composeInternalAIs fs w c = foldr ($ w) c fs +impulsiveAIR + :: (Creature -> Reader World Creature) + -> World + -> (World -> World, StdGen) + -> Creature + -> ((World -> World, StdGen) , Maybe Creature) +impulsiveAIR impf w (f,g) cr = followImpulses w (f,g) . ($ w) . runReader . impf $ cr + impulsiveAI :: (World -> Creature -> Creature) -- ^ Internal AI update, should determine impulses -> World @@ -84,7 +92,7 @@ followImpulse cr w imp = case imp of 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 ) + addDam i dams = Blunt 100 cpos (posFromID i) (posFromID i) : dams actionUpdateAI :: (World -> Creature -> Creature) -- ^ the function updating the actions @@ -93,6 +101,24 @@ actionUpdateAI -> Creature actionUpdateAI actF w c = performActions w $ actF w c +performActionR :: Creature -> Reader World Creature +performActionR cr = reader $ \w -> performActions w cr + +watchUpdateStratR + :: [ ((World, Creature) -> Bool, World -> Creature -> Strategy) ] + -> Creature + -> Reader World Creature +watchUpdateStratR fs cr = case cr ^? crActionPlan . crStrategy of + Just WatchAndWait -> reader $ \w -> cr + & crActionPlan . crStrategy .~ listGuard (fs, \_ _ -> WatchAndWait) (w, cr) w cr + _ -> reader $ \_ -> cr + +listGuard :: ([(a -> Bool, b)] , b) -> a -> b +listGuard ( (test,y):ps, z ) x + | test x = y + | otherwise = listGuard (ps, z) x +listGuard (_,z) _ = z + performActions :: World -> Creature -> Creature performActions w cr = cr & crActionPlan . crImpulse .~ concat iss diff --git a/src/Dodge/Creature/Rationality/Data.hs b/src/Dodge/Creature/Rationality/Data.hs deleted file mode 100644 index 85bfe8ce3..000000000 --- a/src/Dodge/Creature/Rationality/Data.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -module Dodge.Creature.Rationality.Data - where -import Dodge.Creature.Stance.Data -import Geometry.Data - -import Control.Lens diff --git a/src/Dodge/Creature/SetTarget.hs b/src/Dodge/Creature/SetTarget.hs index faeb50965..04c595a20 100644 --- a/src/Dodge/Creature/SetTarget.hs +++ b/src/Dodge/Creature/SetTarget.hs @@ -8,10 +8,11 @@ import Dodge.Creature.AlertLevel.Data import Control.Lens import qualified Data.IntMap.Strict as IM +{- | Assumes that you are id 0: if creature is cognizant of you, sets you as target -} targetYouWhenCognizant :: World -> Creature -> Creature targetYouWhenCognizant w cr = case cr ^? crAwarenessLevel . ix 0 of - Just (Cognizant _) -> cr & crTarget .~ Just (_creatures w IM.! 0) + Just (Cognizant _) -> cr & crTarget ?~ _creatures w IM.! 0 _ -> cr & crTarget .~ Nothing diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index 4be7db2f9..fb49dc107 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -2,7 +2,6 @@ module Dodge.Creature.State where import Dodge.Data import Dodge.Creature.State.Data import Dodge.Creature.Stance.Data -import Dodge.Data import Dodge.Base import Dodge.SoundLogic import Dodge.RandomHelp @@ -16,16 +15,11 @@ import Data.List import Data.Char import Data.Maybe import Data.Function ---import Data.Graph.Inductive.Graph -import Data.Graph.Inductive.PatriciaTree -import Data.Graph.Inductive.Query.SP -import Codec.BMP -import qualified Data.ByteString as B import Control.Lens import Control.Applicative import Control.Monad.State import Control.Monad -import qualified SDL as SDL +import qualified SDL import qualified SDL.Mixer as Mix import System.Random import qualified Data.Set as S @@ -38,7 +32,6 @@ type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World 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 @@ -46,11 +39,11 @@ stateUpdate :: CRUpdate -> CRUpdate stateUpdate u w (f,g) cr = let (cr', g'') = updateMovement g cr in case u w (f,g'') cr' of - ((f',g') , maybeCr) -> ( (invSideEff cr . movementSideEff cr . deathEff . f' - , g') - , fmap (updateReloadCounter . doDamage . crAutoReload) - $ crOrCorpse =<< maybeCr - ) + ((f',g') , maybeCr) -> + ( (invSideEff cr . movementSideEff cr . deathEff . f' + , g') + , fmap (updateReloadCounter . doDamage . crAutoReload) $ crOrCorpse =<< maybeCr + ) where crOrCorpse cr | cr ^. crHP > 0 = Just cr @@ -60,11 +53,11 @@ stateUpdate u w (f,g) cr = | otherwise = stopSoundFrom (CrWeaponSound (_crID cr)) . over decorations addCorpse . dropByState cr - crBeforeDeath = colCrWall w $ cr - addCorpse = insertNewKey $ uncurry translate (_crOldPos cr) - $ rotate (_crDir cr) - (_crCorpse cr) - + crBeforeDeath = colCrWall w cr + addCorpse = insertNewKey + $ uncurry translate (_crOldPos cr) + $ rotate (_crDir cr) + (_crCorpse cr) -- | Drop items according to the creature state. dropByState :: Creature -> World -> World dropByState cr w = foldr (copyItemToFloor cr) w is @@ -75,10 +68,8 @@ dropByState cr w = foldr (copyItemToFloor cr) w is DropSpecific xs -> xs DropAmount n -> take n $ evalState (shuffle $ IM.keys $ _crInv cr) (_randGen w) - setOldPos :: Creature -> Creature setOldPos cr = set crOldPos (_crPos cr) cr - {- | Given a creature and a velocity, applies friction to that creature and evaluates a velocity to carry across frames. @@ -86,17 +77,12 @@ velocity to carry across frames. crFriction :: Creature -> Point2 -> Point2 crFriction cr vel = (0,0) -{- | In order to force a list, apply with seq. -} -forceSpine :: [a] -> () -forceSpine = foldr (const id) () - doDamage :: Creature -> Creature doDamage cr = set (crState . crDamage) [] - $ over (crState . crPastDamage) (f . take 20 . (dams :) ) damagedCr + $ over (crState . crPastDamage) (forceList . take 20 . (dams :) ) damagedCr where - f l = seq (forceSpine l) l dams = _crDamage $ _crState cr - damagedCr = snd $ (_crApplyDamage cr) dams cr + damagedCr = snd $ _crApplyDamage cr dams cr sumDamage :: Creature -> DamageType -> Int -> Int sumDamage cr dm x = x + _dmAmount dm @@ -107,7 +93,7 @@ movementSideEff cr w = case cr ^? crStance . carriage of Just (Boosting v) -> makeFlameletTimed - (oldPos +.+ (_crRad cr + 3) *.* (unitVectorAtAngle $ _crDir cr + pi)) + (oldPos +.+ (_crRad cr + 3) *.* unitVectorAtAngle (_crDir cr + pi)) (momentum +.+ 1 *.* rotateV randDir (vInverse v)) Nothing 1 @@ -128,9 +114,6 @@ movementSideEff cr w (randDir,g) = randomR (-0.5,0.5) $ _randGen w (randAng,_) = randomR (0,2*pi) $ _randGen w - (v1:v2:v3:_) = fst $ runState ((sequence . repeat . randInCirc) 0.1) $ _randGen w - (r1:r2:r3:_) = map ((*.*) 100) (v2:v3:v1:[]) - crHasMoved = dist (_crPos cr) (_crOldPos cr) > 0.5 takeStep x y | crHasMoved && x < 20 && x + y >= 20 = soundMultiFrom footor 22 3 0 | crHasMoved && x < 80 && x + y >= 80 = soundMultiFrom footor 23 3 0 @@ -139,15 +122,16 @@ movementSideEff cr w invSideEff :: Creature -> World -> World invSideEff cr w = weaponReloadSounds cr $ IM.foldrWithKey f w (_crInv cr) - where f i it w' = case it ^? itEffect . itInvEffect of - Nothing -> w' - Just g -> g cr i w' + where + f i it w' = case it ^? itEffect . itInvEffect of + Nothing -> w' + Just g -> g cr i w' weaponReloadSounds :: Creature -> World -> World weaponReloadSounds cr w = case _crInv cr IM.!? _crInvSel cr of - Just (Weapon {_wpReloadState = 0}) -> w - Just (Weapon {_wpReloadState = 1}) -> stopSoundFrom (CrReloadSound cid) w - Just (Weapon {}) -> soundFrom (CrReloadSound cid) reloadSound (1) 0 w + Just Weapon{_wpReloadState = 0} -> w + Just Weapon{_wpReloadState = 1} -> stopSoundFrom (CrReloadSound cid) w + Just Weapon{} -> soundFrom (CrReloadSound cid) reloadSound 1 0 w _ -> w where cid = _crID cr @@ -171,7 +155,7 @@ updateMovement g cr isFrictionless :: Creature -> Bool isFrictionless cr = case cr ^? crStance . carriage of Just (Boosting _) -> True - Just (Floating) -> True + Just Floating -> True _ -> False updateReloadCounter :: Creature -> Creature @@ -212,12 +196,11 @@ updateExpBarrel w (f,g) cr damages = _crDamage $ _crState cr pierceSparks :: [World -> World] pierceSparks - = zipWith4 (\p a colid time-> (createBarrelSpark time colid (_crPos cr +.+ p) (a + argV p)) - (Just $ _crID cr)) - poss as colids times - as = randomRs (-0.7,0.7) $ g - colids = randomRs (0,11) $ g - times = randomRs (2,5) $ g + = zipWith4 (\p a -> createBarrelSpark (_crPos cr +.+ p) (a + argV p) (Just $ _crID cr)) + poss as times colids + as = randomRs (-0.7,0.7) g + colids = randomRs (0,11) g + times = randomRs (2,5) g (g',_) = split g poss = _piercedPoints $ _crSpState $ _crState cr --newCr = Just $ doDamage $ applyFuseDamage cr -- $ foldr perforate cr damages @@ -229,7 +212,7 @@ updateExpBarrel w (f,g) cr applyFuseDamage cr = over crHP (\hp -> hp - length (_piercedPoints $ _crSpState $ _crState cr)) cr - hiss | poss == [] = id + hiss | null poss = id | otherwise = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1 stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1) @@ -237,14 +220,14 @@ damToExpBarrel :: [DamageType] -> Creature -> Creature damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam) otherDam where (pierceDam,otherDam) = partition isPierce ds - isPierce (Piercing {}) = True + isPierce Piercing{} = True isPierce _ = False damToExpBarrel' :: DamageType -> Creature -> Creature damToExpBarrel' (Piercing amount sp int ep) cr = over (crState . crSpState . piercedPoints) ((:) $ int -.- _crPos cr) $ over crHP (\hp -> hp - div amount 200) cr -damToExpBarrel' (PoisonDam {}) cr = cr -damToExpBarrel' (SparkDam {}) cr = cr -damToExpBarrel' (PushDam {_dmPushBack = v}) cr = cr Control.Lens.& crPos %~ (+.+) (1 / _crMass cr *.* v) +damToExpBarrel' PoisonDam {} cr = cr +damToExpBarrel' SparkDam {} cr = cr +damToExpBarrel' PushDam{_dmPushBack = v} cr = cr Control.Lens.& crPos %~ (+.+) (1 / _crMass cr *.* v) damToExpBarrel' dt cr = cr Control.Lens.& crHP -~ _dmAmount dt diff --git a/src/Dodge/Creature/State/Data.hs b/src/Dodge/Creature/State/Data.hs index 7dbd8af01..c2bd726f7 100644 --- a/src/Dodge/Creature/State/Data.hs +++ b/src/Dodge/Creature/State/Data.hs @@ -4,31 +4,25 @@ module Dodge.Creature.State.Data where import Geometry import Dodge.Data.DamageType -import Dodge.Creature.Impulse.Data import Dodge.Creature.Stance.Data import Picture.Data import Control.Lens import qualified Data.IntSet as IS - data CreatureState = CrSt - { _goals :: [[Impulse]] - , _crDamage :: [DamageType] + { _crDamage :: [DamageType] , _crPastDamage :: [[DamageType]] , _crSpState :: CrSpState , _crDropsOnDeath :: CreatureDropType } - data CreatureDropType = DropAll | DropAmount Int | DropSpecific [Int] - data CrSpState = Barrel { _piercedPoints :: [Point2]} | GenCr deriving (Eq,Show,Ord) - data Faction = GenericFaction Int | ZombieFaction @@ -39,11 +33,12 @@ data Faction | ColorFaction Color | PlayerFaction deriving (Eq,Show) - data CrGroup = LoneWolf - | Swarm { _swarm :: IS.IntSet } - + | Swarm + { _swarm :: IS.IntSet + , _crGroupID :: Int + } + | CrGroupID { _crGroupID :: Int } makeLenses ''CreatureState makeLenses ''CrSpState -makeLenses ''Impulse diff --git a/src/Dodge/Creature/SwarmCrit.hs b/src/Dodge/Creature/SwarmCrit.hs index d1434d20e..1a60ff0ee 100644 --- a/src/Dodge/Creature/SwarmCrit.hs +++ b/src/Dodge/Creature/SwarmCrit.hs @@ -32,14 +32,15 @@ swarmCrit = defaultCreature { _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs [ flockPointTarget encircle targetYouLOS , \ _ -> crMeleeCooldown . _Just %~ (max 0 . subtract 1) + , basicPerceptionUpdate [0] +-- , doStrategyActions +-- , targetYouWhenCognizant ] , _crHP = 1 , _crRad = 2 + , _crMass = 2 , _crPict = basicCrPict yellow - , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 2 , _crFaction = ColorFaction yellow , _crMeleeCooldown = Just 0 } - - diff --git a/src/Dodge/Creature/Test.hs b/src/Dodge/Creature/Test.hs index 22554dd7b..432fef2d2 100644 --- a/src/Dodge/Creature/Test.hs +++ b/src/Dodge/Creature/Test.hs @@ -16,6 +16,7 @@ import Data.List (find) import Data.Maybe import qualified Data.IntMap.Strict as IM import Control.Lens +import Control.Monad.Reader andTest :: (a -> Bool) -> (a -> Bool) -> a -> Bool andTest f g a = f a && g a @@ -28,31 +29,61 @@ crIsReloading (w,cr) = case cr ^? crInv . ix (_crInvSel cr) . wpReloadState of Just t -> t > 0 _ -> False +crIsReloadingR :: Creature -> Reader World Bool +crIsReloadingR cr = return $ case cr ^? crInv . ix (_crInvSel cr) . wpReloadState of + Just t -> t > 0 + _ -> False + crCanSeeCr :: Creature -> (World, Creature) -> Bool crCanSeeCr tcr (w,cr) = hasLOS (_crPos cr) (_crPos tcr) w +crCanSeeR :: Creature -> Creature -> Reader World Bool +crCanSeeR tcr cr = reader $ \w -> hasLOS (_crPos cr) (_crPos tcr) w + crCanSeeCID :: Int -> (World, Creature) -> Bool crCanSeeCID cid (w,cr) = hasLOS (_crPos cr) (_crPos $ _creatures w IM.! cid) w +crCanSeeCIDR :: Int -> Creature -> Reader World Bool +crCanSeeCIDR cid cr = reader $ \w -> hasLOS (_crPos cr) (_crPos $ _creatures w IM.! cid) w + crIsAiming :: (World,Creature) -> Bool crIsAiming (_,cr) = _posture (_crStance cr) == Aiming +crIsAimingR :: Creature -> Reader World Bool +crIsAimingR cr = return $ _posture (_crStance cr) == Aiming + crHasTarget :: (World,Creature) -> Bool crHasTarget (_,cr) = isJust $ cr ^? crTarget . _Just +crHasTargetR :: Creature -> Reader World Bool +crHasTargetR cr = return $ isJust $ cr ^? crTarget . _Just + crHasTargetLOS :: (World,Creature) -> Bool crHasTargetLOS (w,cr) = case cr ^? crTarget . _Just of Just i -> crCanSeeCr i (w,cr) Nothing -> False +crHasTargetLOSR :: Creature -> Reader World Bool +crHasTargetLOSR cr = reader $ \w -> case cr ^? crTarget . _Just of + Just i -> crCanSeeCr i (w,cr) + Nothing -> False + crSafeDistFromTarg :: Float -> (World,Creature) -> Bool crSafeDistFromTarg d (w,cr) = case cr ^? crTarget . _Just of Just tcr -> dist (_crPos cr) (_crPos tcr) > d Nothing -> True +crSafeDistFromTargR :: Float -> Creature -> Reader World Bool +crSafeDistFromTargR d cr = reader $ \w -> case cr ^? crTarget . _Just of + Just tcr -> dist (_crPos cr) (_crPos tcr) > d + Nothing -> True + crStratConMatches :: Strategy -> (World,Creature) -> Bool crStratConMatches strat (_,cr) = eqConstr strat (_crStrategy $ _crActionPlan cr) +crStratConMatchesR :: Strategy -> Creature -> Reader World Bool +crStratConMatchesR strat cr = return $ eqConstr strat (_crStrategy $ _crActionPlan cr) + crAwayFromPost :: (World,Creature) -> Bool crAwayFromPost (_,cr) = case find sentinelGoal $ _crGoal $ _crActionPlan cr of Just (SentinelAt p dir) -> dist p (_crPos cr) > 15 @@ -60,3 +91,11 @@ crAwayFromPost (_,cr) = case find sentinelGoal $ _crGoal $ _crActionPlan cr of where sentinelGoal (SentinelAt p dir) = True sentinelGoal _ = False + +crAwayFromPostR :: Creature -> Reader World Bool +crAwayFromPostR cr = return $ case find sentinelGoal $ _crGoal $ _crActionPlan cr of + Just (SentinelAt p dir) -> dist p (_crPos cr) > 15 + _ -> False + where + sentinelGoal (SentinelAt p dir) = True + sentinelGoal _ = False diff --git a/src/Dodge/Creature/Update.hs b/src/Dodge/Creature/Update.hs index a72eb331d..7afceb4ae 100644 --- a/src/Dodge/Creature/Update.hs +++ b/src/Dodge/Creature/Update.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} module Dodge.Creature.Update where import Dodge.Data diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index bc2b4ee94..221077bbc 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -16,10 +16,8 @@ module Dodge.Data , soundTime ) where import Dodge.Picture.Layer.Data -import Dodge.Creature.Data import Dodge.Creature.State.Data import Dodge.Creature.Stance.Data -import Dodge.Creature.Rationality.Data import Dodge.Creature.AlertLevel.Data import Dodge.Data.Menu import Dodge.Data.SoundOrigin @@ -42,6 +40,7 @@ import Data.Data import Data.Graph.Inductive import Data.Int (Int16) import qualified Data.Set as S +import qualified Data.IntSet as IS import qualified Data.IntMap.Strict as IM import qualified Data.Map as M import qualified Data.DList as DL @@ -58,6 +57,7 @@ data World = World , _cameraViewFrom :: !Point2 , _creatures :: IM.IntMap Creature , _creaturesZone :: IM.IntMap (IM.IntMap (IM.IntMap Creature)) + , _creatureGroups :: IM.IntMap CrGroupParams , _itemPositions :: IM.IntMap ItemPos , _clouds :: IM.IntMap Cloud , _cloudsZone :: IM.IntMap (IM.IntMap (IM.IntMap Cloud)) @@ -65,7 +65,7 @@ data World = World , _particles :: ![Particle] , _staticWalls :: [Wall] , _walls :: !(IM.IntMap Wall) - , _wallsZone :: (IM.IntMap (IM.IntMap (IM.IntMap Wall))) + , _wallsZone :: IM.IntMap (IM.IntMap (IM.IntMap Wall)) , _forceFields :: IM.IntMap ForceField , _floorItems :: IM.IntMap FloorItem , _randGen :: StdGen @@ -104,7 +104,13 @@ data World = World , _config :: Configuration , _sideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)] , _doneSideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)] - } + } +data CrGroupParams = CrGroupParams + { _crGroupParamID :: Int + , _crGroupIDs :: IS.IntSet + , _crGroupCenter :: Point2 + , _crGroupUpdate :: World -> CrGroupParams -> Maybe CrGroupParams + } data Corpse = Corpse { _cpPos :: Point2 , _cpPict :: Picture @@ -380,8 +386,7 @@ data Particle , _btMaxTime' :: Int , _btTimer' :: Int } -type HitEffect = Particle -> [(Point2, (Either3 Creature Wall ForceField))] -> World - -> (World,Maybe Particle) +type HitEffect = Particle -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World,Maybe Particle) data Projectile = Projectile { _pjPos :: Point2 @@ -540,26 +545,26 @@ data Action ,_waitThenAction :: Action } | DoActionWhile - {_doActionWhileCondition :: ( (World, Creature) -> Bool) + {_doActionWhileCondition :: (World, Creature) -> Bool ,_doActionWhileAction :: Action } | DoActionWhilePartial {_doActionWhilePartial :: Action - ,_doActionWhileCondition :: ( (World, Creature) -> Bool) + ,_doActionWhileCondition :: (World, Creature) -> Bool ,_doActionWhileAction :: Action } | DoActionIf - {_doActionIfCondition :: ( (World, Creature) -> Bool) + {_doActionIfCondition :: (World, Creature) -> Bool ,_doActionIfAction :: Action } | DoActionIfElse {_doActionIfElseIfAction :: Action - ,_doActionIfElseCondition :: ( (World, Creature) -> Bool) + ,_doActionIfElseCondition :: (World, Creature) -> Bool ,_doActionIfElseElseAction :: Action } | DoActionWhileThen {_doActionWhileThenDo :: Action - ,_doActionWhileThenCondition :: ( (World, Creature) -> Bool) + ,_doActionWhileThenCondition :: (World, Creature) -> Bool ,_doActionWhileThenThen :: Action } | DoActions @@ -619,6 +624,7 @@ data Strategy | GetTo Point2 | Reload | Flee + | MeleeStrike deriving (Generic) -- deriving (Eq,Ord,Show) data Goal @@ -646,6 +652,7 @@ makeLenses ''Button makeLenses ''ActionPlan makeLenses ''Impulse makeLenses ''Action +makeLenses ''CrGroupParams numColor :: Int -> Color numColor 0 = (1,0,0,1) diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 420a6a1bf..120adefc9 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {- | Module : Dodge.Default Description : Instances of data structures @@ -10,7 +9,6 @@ import Dodge.Item.Weapon.ExtraEffect import Dodge.Data import Dodge.Creature.Stance.Data import Dodge.Creature.State.Data -import Dodge.Creature.Rationality.Data import Dodge.Creature.AlertLevel.Data import Dodge.Data.Menu import Dodge.SoundLogic @@ -45,15 +43,13 @@ defaultCrystalWall = Wall , _wlSeen = False , _wlIsSeeThrough = True } - -{- -Door that opens on approach. +{- Door that opens on approach. Pathable. -} defaultAutoDoor = Door { _wlLine = ((0,0),(50,0)) , _wlID = 0 , _doorMech = id - , _wlColor = light $ dim $ dim $ dim $ yellow + , _wlColor = light $ dim $ dim $ dim yellow , _wlSeen = False , _wlIsSeeThrough = False , _doorPathable = True @@ -66,7 +62,7 @@ defaultDoor = Door { _wlLine = ((0,0),(50,0)) , _wlID = 0 , _doorMech = id - , _wlColor = light $ dim $ dim $ dim $ yellow + , _wlColor = light $ dim $ dim $ dim yellow , _wlSeen = False , _wlIsSeeThrough = False , _doorPathable = False @@ -101,8 +97,7 @@ defaultCreature = Creature , _crGroup = LoneWolf } defaultState = CrSt - { _goals = [] - , _crDamage = [] + { _crDamage = [] , _crPastDamage = [] , _crSpState = GenCr , _crDropsOnDeath = DropAmount 1 @@ -143,7 +138,7 @@ defaultApplyDamage :: [DamageType] -> Creature -> (World -> World, Creature) defaultApplyDamage ds cr = (id, doPoisonDam $ foldr (\d c -> snd $ applyIndividualDamage d c) cr ds') where (ps,ds') = partition isPoison ds - isPoison (PoisonDam {}) = True + isPoison PoisonDam{} = True isPoison _ = False poisonDam = quot (max 0 (sum (map _dmAmount ps))) 10 doPoisonDam = over crHP (\hp -> hp - poisonDam) @@ -174,7 +169,7 @@ defaultIt = Consumable , _itName = "defaultIt" , _itMaxStack = 3 , _itAmount = 2 - , _cnEffect = \ _ -> return + , _cnEffect = const return , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] , _itEquipPict = \cr _ -> blank , _itID = Nothing @@ -187,10 +182,10 @@ defaultButton = Button { _btPict = onLayer WlLayer $ color red $ polygon $ rectNSEW 5 (-5) 10 (-10) , _btPos = (0,0) , _btRot = 0 - , _btEvent = \b w -> set (buttons . ix (_btID b) . btPict) - (onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10)) - . set (buttons . ix (_btID b) . btState) BtNoLabel - . soundOnce 1 $ w + , _btEvent = \b w -> + set (buttons . ix (_btID b) . btPict) (onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10)) + . set (buttons . ix (_btID b) . btState) BtNoLabel + . soundOnce 1 $ w , _btID = 0 , _btText = "Button" , _btState = BtOff @@ -204,15 +199,13 @@ defaultPT = Projectile , _pjUpdate = id } defaultPP = PressPlate - { _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright $ blue) $ circleSolid 5 + { _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright blue) $ circleSolid 5 , _ppPos = (0,0) , _ppRot = 0 - , _ppEvent = \pp -> id + , _ppEvent = const id , _ppID = -1 , _ppText = "Pressure plate" } --- }}} - defaultWorld = World { _keys = S.empty , _mouseButtons = S.empty @@ -222,6 +215,7 @@ defaultWorld = World , _cameraViewFrom = (0,0) , _creatures = IM.empty , _creaturesZone = IM.empty + , _creatureGroups = IM.empty , _clouds = IM.empty , _cloudsZone = IM.empty , _itemPositions = IM.empty diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 8a0908a38..9e7ba354d 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -108,14 +108,14 @@ wheelUpEvent w = case _carteDisplay w of wheelDownEvent :: World -> World wheelDownEvent w = case _carteDisplay w of - True | rbDown -> w & carteZoom .~ max 0.05 (z-(0.1*z)) - | otherwise -> w & selLocation %~ (`mod` numLocs) . (\i -> i + 1) - False | rbDown -> fromMaybe (closeObjScrollDown w) - $ (yourItem w ^? itScrollDown) - <*> pure (_crInvSel (you w)) - <*> pure w - | lbDown -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01} - | otherwise -> downInvPos w + True + | rbDown -> w & carteZoom .~ max 0.05 (z-(0.1*z)) + | otherwise -> w & selLocation %~ (`mod` numLocs) . (+ 1) + False + | rbDown -> fromMaybe (closeObjScrollDown w) + $ (yourItem w ^? itScrollDown) <*> pure (_crInvSel (you w)) <*> pure w + | lbDown -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01} + | otherwise -> downInvPos w where rbDown = ButtonRight `S.member` _mouseButtons w lbDown = ButtonLeft `S.member` _mouseButtons w diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 2e188ed7a..8b32332fb 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -25,7 +25,6 @@ import qualified Data.Set as S import Control.Lens import Picture - {- | Handles keyboard press and release. On release, remove scancode from the 'Set' of pressed keys. On press, adds the scancode, and perhaps applies a direct effect: @@ -58,7 +57,6 @@ 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 debugKey :: Scancode -> World -> Maybe World debugKey scancode w diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 7ec65bb40..f6553534d 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -40,8 +40,7 @@ import Control.Lens import Control.Monad.State import Control.Monad.Loops import System.Random -{- | -A test level tree. -} +{- | A test level tree. -} roomTreex :: RandomGen g => State g (Maybe [Room]) roomTreex = do struct' <- aTreeStrut @@ -51,16 +50,19 @@ roomTreex = do t = treeFromTrunk [[StartRoom] ,[Corridor] + ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 + & rmPS %~ ([sPS (0,50) 0 $ PutCrit chaseCrit ]++) + ] + ,[Corridor] ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200] ]++) ] ,[Corridor] ,[Corridor] - ,[SpecificRoom . fmap (pure . Right) $ twinSlowDoorChasers 30] + ,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers 30] ,[Corridor] ,[DoorAno] - ,[SpecificRoom $ fmap (pure . Right) - $ centerVaultExplosiveExit 50] + ,[SpecificRoom $ pure . Right <$> centerVaultExplosiveExit 50] ,[SpecificRoom blockedCorridor] ,[OrAno [[DoorAno] ,[Corridor] @@ -82,8 +84,7 @@ roomTreex = do ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]] ] t' - fmap (shiftExpandTree . expandTreeBy id) $ mapM annoToRoomTree t + shiftExpandTree . expandTreeBy id <$> mapM annoToRoomTree t levx :: RandomGen g => State g [Room] levx = untilJust roomTreex - diff --git a/src/Dodge/Graph.hs b/src/Dodge/Graph.hs index 02ad7192e..7f4de0f4d 100644 --- a/src/Dodge/Graph.hs +++ b/src/Dodge/Graph.hs @@ -1,18 +1,20 @@ module Dodge.Graph where import Data.Function (on) -import Data.List +import Data.List.Extra +import Data.Bifunctor (first) import Data.Graph +import Data.Maybe pairsToIncidence :: (Eq a,Ord a) => [(a,a)] -> [(a,[a])] -pairsToIncidence = map ((\(xs,ys) -> (head xs,ys)) . unzip) - . groupBy ( (==) `on` fst) - . sort +pairsToIncidence + = map (first head . unzip) + . groupOn fst + . sort incidenceToFunction :: Eq a => [(a,[a])] -> a -> [a] -incidenceToFunction xs a = case lookup a xs of Just ys -> ys - Nothing -> [] +incidenceToFunction xs a = fromMaybe [] $ lookup a xs mkNode :: (a,[a]) -> (a,a,[a]) mkNode (x,xs) = (x,x,xs) diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index 336247c03..688de89f2 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -2,30 +2,27 @@ module Dodge.Inventory where import Dodge.Data import Dodge.Base ---import Dodge.SoundLogic - import Geometry import Data.Maybe import Data.List import Data.Function (on) import qualified Data.IntMap.Strict as IM - import System.Random - import Control.Lens checkInvSlotsYou' :: Maybe Item -> World -> Maybe Int -checkInvSlotsYou' it w = fmap fst $ find cond invListSelFirst - where cond (_,NoItem) = True - cond (_,it' ) = itNotFull it' && fmap _itName it == Just (_itName it') - youCr = you w - youSel = _crInvSel youCr - invList = _crInv youCr - invListSelFirst = (youSel , invList IM.! youSel) : IM.toList invList +checkInvSlotsYou' it w = fst <$> find cond invListSelFirst + where + cond (_,NoItem) = True + cond (_,it' ) = itNotFull it' && fmap _itName it == Just (_itName it') + youCr = you w + youSel = _crInvSel youCr + invList = _crInv youCr + invListSelFirst = (youSel , invList IM.! youSel) : IM.toList invList checkInvSlotsYou :: Item -> World -> Maybe Int -checkInvSlotsYou it w = fmap fst $ find cond invListSelFirst +checkInvSlotsYou it w = fst <$> find cond invListSelFirst where cond (_,NoItem) = True cond (_,it' ) = itNotFull it' && _itName it == _itName it' @@ -36,8 +33,9 @@ checkInvSlotsYou it w = fmap fst $ find cond invListSelFirst checkInvSlots :: Item -> IM.IntMap Item -> Maybe Int checkInvSlots it its = fmap fst $ find cond $ IM.toList its - where cond (_,NoItem) = True - cond (_,it' ) = itNotFull it' && _itName it == _itName it' + where + cond (_,NoItem) = True + cond (_,it' ) = itNotFull it' && _itName it == _itName it' addItem :: Item -> Item -> Item addItem it NoItem = it @@ -57,7 +55,7 @@ rmInvItem rmInvItem n i w = let item = _crInv (_creatures w IM.! n) IM.! i itRef = creatures . ix n . crInv . ix i - in case item of + in case item of Consumable {_itAmount = 1} -> set itRef NoItem w Craftable {_itAmount = 1} -> set itRef NoItem w Equipment {_itAmount = 1} -> set itRef NoItem w @@ -67,28 +65,25 @@ rmInvItem n i w = Equipment {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w Throwable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w _ -> set itRef NoItem w - -{- -Delete a creature's selected item, the item will no longer exist. - -} +{- Delete a creature's selected item, the item will no longer exist. -} rmSelectedInvItem :: Int -- ^ Creature id -> World -> World rmSelectedInvItem cid w = rmInvItem cid (_crInvSel (_creatures w IM.! cid)) w - -- for now, left are floor items, right are buttons closestActiveObject :: World -> Maybe (Either FloorItem Button) -closestActiveObject w = listToMaybe $ sortBy (compare `on` dist ypos . pos) $ actObjs - where ypos = _crPos $ you w - actObjs = filter (\obj -> dist ypos (pos obj) < 40 && hasLOS ypos (pos obj) w) - $ map Left (IM.elems $ _floorItems w) ++ activeButtons -- map Right (IM.elems $ _buttons w) - pos (Right x) = _btPos x - pos (Left x) = _flItPos x - activeButtons = map Right - . filter ( (/=) BtNoLabel . _btState) - . IM.elems - $ _buttons w +closestActiveObject w = listToMaybe $ sortOn (dist ypos . pos) actObjs + where + ypos = _crPos $ you w + actObjs = filter (\obj -> dist ypos (pos obj) < 40 && hasLOS ypos (pos obj) w) + $ map Left (IM.elems $ _floorItems w) ++ activeButtons -- map Right (IM.elems $ _buttons w) + pos (Right x) = _btPos x + pos (Left x) = _flItPos x + activeButtons = map Right + . filter ( (/=) BtNoLabel . _btState) + . IM.elems + $ _buttons w updateCloseObjects :: World -> World updateCloseObjects w = w & closeActiveObjects .~ unionBy eTest oldCloseFiltered currentClose diff --git a/src/Dodge/Item.hs b/src/Dodge/Item.hs index d6a06cf73..38428b019 100644 --- a/src/Dodge/Item.hs +++ b/src/Dodge/Item.hs @@ -13,7 +13,7 @@ keyToken n = defaultEquipment , _itName = "KEYTOKEN "++show n , _itMaxStack = 5 , _itAmount = 1 - , _itFloorPict = setDepth 0.5 $ keyPic + , _itFloorPict = setDepth 0.5 keyPic , _itEquipPict = \cr _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic , _itEffect = NoItEffect , _itHammer = HammerUp @@ -36,7 +36,7 @@ latchkey n = defaultEquipment , _itName = "KEY "++show n , _itMaxStack = 1 , _itAmount = 1 - , _itFloorPict = setDepth 0.5 $ latchkeyPic + , _itFloorPict = setDepth 0.5 latchkeyPic , _itEquipPict = \cr _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic , _itEffect = NoItEffect , _itHammer = HammerUp diff --git a/src/Dodge/Item/Consumable.hs b/src/Dodge/Item/Consumable.hs index bc73d29c1..99e437db6 100644 --- a/src/Dodge/Item/Consumable.hs +++ b/src/Dodge/Item/Consumable.hs @@ -29,6 +29,5 @@ heal25 :: Int -> World -> Maybe World heal25 = heal 25 heal :: Int -> Int -> World -> Maybe World heal hp n w | _crHP (_creatures w IM.! n) >= 10000 = Nothing - | otherwise = Just $ soundOnce healSound - $ over (creatures . ix n . crHP) ((min 10000) . (+ hp) ) w + | otherwise = Just $ soundOnce healSound w & creatures . ix n . crHP %~ min 10000 . (+ hp) diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index efb4eb1a4..3428c3167 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -1,8 +1,5 @@ -{- | -Definitions of weapons. -In progress: move out effects into other modules. - -} -{-# LANGUAGE BangPatterns #-} +{- | Definitions of weapons. +In progress: move out effects into other modules. -} module Dodge.Item.Weapon ( module Dodge.Item.Weapon ) diff --git a/src/Dodge/Item/Weapon/Bullet.hs b/src/Dodge/Item/Weapon/Bullet.hs index 285614321..06c5a6139 100644 --- a/src/Dodge/Item/Weapon/Bullet.hs +++ b/src/Dodge/Item/Weapon/Bullet.hs @@ -145,7 +145,7 @@ bulHitWall' bt p x w = damageBlocks x spid = newKey $ _projectiles w reflectDir wall = a + argV (reflectIn (uncurry (-.-) (_wlLine wall)) (p -.- sp) ) damageBlocks wall w = case wall ^? blHP of - Just hp -> foldr (\j -> (walls . ix j . blHP -~ 5)) w (_blIDs wall) + Just hp -> foldr (\j -> walls . ix j . blHP -~ 5) w (_blIDs wall) _ -> w {- | Bounce off walls, do damage to blocks. -} bulBounceWall' :: Particle -> Point2 -> Wall -> World -> World @@ -155,7 +155,7 @@ bulBounceWall' bt p wl w = damageBlocks wl $ over worldEvents addBouncer w pOut = p +.+ safeNormalizeV (sp -.- p) damageBlocks wall w = case wall ^? blHP of - Just hp -> foldr (\j -> (walls . ix j . blHP -~ 5)) w (_blIDs wall) + Just hp -> foldr (\j -> walls . ix j . blHP -~ 5) w (_blIDs wall) _ -> w bouncer = (aGenBulAt' Nothing (_btColor' bt) pOut reflectVel (_btHitEffect' bt) (_btWidth' bt) @@ -180,7 +180,7 @@ bulIncWall' bt p wl w = damageBlocks wl $ incFlamelets w pOut = p +.+ safeNormalizeV (sp -.- p) damageBlocks wall w = case wall ^? blHP of - Just hp -> foldr (\j -> (walls . ix j . blHP -~ 5)) w (_blIDs wall) + Just hp -> foldr (\j -> walls . ix j . blHP -~ 5) w (_blIDs wall) _ -> w wallV = uncurry (-.-) (_wlLine wl) reflectVel = safeNormalizeV $ reflectIn wallV (_btVel' bt) @@ -198,9 +198,9 @@ bulConWall' bt p wl w = damageBlocks wl $ mkwave w pOut = p +.+ safeNormalizeV (sp -.- p) damageBlocks wall w = case wall ^? blHP of - Just hp -> foldr (\j -> (walls . ix j . blHP -~ 5)) w (_blIDs wall) + Just hp -> foldr (\j -> walls . ix j . blHP -~ 5) w (_blIDs wall) _ -> w - mkwave = over worldEvents ((makeShockwaveAt [] p 15 4 1 white) . ) + mkwave = over worldEvents ( makeShockwaveAt [] p 15 4 1 white . ) hvBulHitWall' :: Particle @@ -218,7 +218,7 @@ hvBulHitWall' bt p x w = damageBlocks x $ set randGen g $ foldr ($) w (sparks p argV (reflectIn (uncurry (-.-) (_wlLine wall)) (p -.- sp) ) sv = unitVectorAtAngle $ reflectDir x damageBlocks wall w = case wall ^? blHP of - Just hp -> foldr (\j -> (walls . ix j . blHP -~ 20)) w (_blIDs wall) + Just hp -> foldr (\j -> walls . ix j . blHP -~ 20) w (_blIDs wall) _ -> w cs = take 10 $ randomRs (0,11) $ _randGen w ds = randomRs (-0.7,0.7) $ _randGen w diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index 6a48c43b5..b5909e678 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -370,7 +370,7 @@ spreadNumVelWthHiteff spread num vel wth eff cid w = over particles (newbuls ++) poss dirs colids poss = map ((+.+) $ _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)) $ (replicateM num . randInCirc) 5 & evalState $ _randGen w - dirs = map ((_crDir cr) +) $ zipWith (+) + dirs = map (_crDir cr +) $ zipWith (+) [-spread,-spread+(2*spread/fromIntegral num)..] (randomRs (0,spread/5) (_randGen w)) colids = take num $ randomRs (0,11) (_randGen w) diff --git a/src/Dodge/Item/Weapon/UseEffect.hs b/src/Dodge/Item/Weapon/UseEffect.hs index 9509e8ba9..094a29d11 100644 --- a/src/Dodge/Item/Weapon/UseEffect.hs +++ b/src/Dodge/Item/Weapon/UseEffect.hs @@ -96,7 +96,7 @@ mvRadar x p w pt = ) where pic = onLayerL [levLayer ShadowLayer, 1] $ pictures sweepPics - putBlips = over worldEvents ( ( over particles (blips ++) ) . ) + putBlips = over worldEvents ( over particles (blips ++) . ) blips = map (\p -> blipAt p (withAlpha (0.5*globalAlpha) red) 50) circPoints circPoints = mapMaybe (\wl -> uncurry collidePointCircCorrect (_wlLine wl) r p) $ map (over wlLine swp) (IM.elems $ wallsAlongCirc p r w) diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index f173301b4..f3c8b727e 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -25,7 +25,7 @@ import Data.Maybe import Data.Tree import Data.Either import Data.Function -import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Graph hiding ((&)) import Data.Graph.Inductive.Basic import Data.Graph.Inductive.PatriciaTree import Data.Graph.Inductive.NodeMap @@ -61,16 +61,17 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts updateWallZoning :: World -> World updateWallZoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) w where - wallInZone wl | uncurry dist (_wlLine wl) <= 2*zoneSize - = insertIMInZone x y wlid wl - | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips - where (x,y) = zoneOfPoint $ (uncurry pHalf (_wlLine wl)) - wlid = _wlID wl - ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl) + wallInZone wl + | uncurry dist (_wlLine wl) <= 2*zoneSize = insertIMInZone x y wlid wl + | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips + where + (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl) + wlid = _wlID wl + ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl) makePath :: Tree Room -> [(Point2,Point2)] -makePath = concat . map _rmPath . flatten +makePath = concatMap _rmPath . flatten -- consider nubbing walls after dividing them wallsFromTree :: Tree Room -> IM.IntMap Wall @@ -81,7 +82,7 @@ wallsFromTree t = . removeInverseWalls . foldr cutWalls [] -- map (map (g . roundPoint2)) -- . map (map roundPoint2) - $ (concatMap _rmPolys $ flatten t) + $ concatMap _rmPolys (flatten t) where assignKeys = IM.fromList . zip [0..] . zipWith f [0..] f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i} @@ -98,9 +99,8 @@ wallsFromRooms = divideWall :: Wall -> [Wall] divideWall wl = let (a,b) = _wlLine wl - --ps = divideLine (zoneSize * 2) a b ps = divideLine (zoneSize * 2) a b - in map (\(x,y) -> wl {_wlLine = (x,y)}) $ zip (init ps) (tail ps) + in zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps) divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall divideWallIn wl wls = @@ -130,7 +130,7 @@ shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $ (_rmLinks t) ts where - f r = shiftRoomBy ((0,0) -.- (rotateV (pi-a) p),0) $ shiftRoomBy ((0,0),pi-a) r + f r = shiftRoomBy ( (0,0) -.- rotateV (pi-a) p , 0) $ shiftRoomBy ((0,0),pi-a) r where (p,a) = last $ _rmLinks r diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 8f323f384..4014eb6fe 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} -- | deals with placement of objects within the world -- after they have had their coordinates set by the layout @@ -8,9 +7,7 @@ module Dodge.LevelGen , pairsToGraph , makeButton , makeSwitch - ) - where - + ) where import Dodge.Data import Dodge.Base import Dodge.Room.Data @@ -29,22 +26,24 @@ import System.Random import Control.Monad.State import Control.Applicative import Control.Lens -import Data.List +import Data.List.Extra import Data.Function import Data.Maybe import qualified Data.IntMap.Strict as IM import qualified Data.Set as S import qualified Data.Map as M - placeSpots :: [Placement] -> World -> World -placeSpots pss w = foldr placeSpot w' $ map _placementSpot singlePlacements +placeSpots pss w = foldr (placeSpot . _placementSpot) w' singlePlacements where (singlePlacements, groupedPlacements) = partition isSPS pss - isSPS (SinglePlacement {}) = True + isSPS SinglePlacement{} = True isSPS _ = False - gplmnts = groupBy ((==) `on` _groupPlacementID) $ sortOn _groupPlacementID groupedPlacements - w' = foldr updateGroup w gplmnts + gplmnts :: [[Placement]] + gplmnts = groupOn _groupPlacementID $ sortOn _groupPlacementID groupedPlacements + w' = foldr putGroup w gplmnts + putGroup :: [Placement] -> World -> World + putGroup gps w = (_groupUpdate $ head gps) w gps {- | OK, this is perhaps slightly impenetrable. - The idea is that for a list of collected group placements, we first update @@ -53,20 +52,20 @@ placeSpots pss w = foldr placeSpot w' $ map _placementSpot singlePlacements - After this, for each placement we apply the group placement function to - the psType using a zipWith, and taking all the pstypes as a paramenter, - then successively update the world using a foldr. -} -updateGroup :: [Placement] -> World -> World -updateGroup ps w = - let (w', psTypes) = mapAccumR updateSpot w $ map _placementSpot ps - fs = zipWith (\gp pst -> _groupPlacementFunc gp psTypes pst) ps psTypes - in foldr ($) w' fs - -updateSpot :: World -> PlacementSpot -> (World, PSType) -updateSpot w ps = case _psType ps of - PutButton bt -> undefined - PutCrit cr -> placeUpdateCr cr p rot w - where - p = _psPos ps - rot = _psRot ps - +--updateGroup :: [Placement] -> World -> World +--updateGroup ps w = +-- let (w', psTypes) = mapAccumR updateSpot w $ map _placementSpot ps +-- fs = zipWith (\gp pst -> _groupPlacementFunc gp psTypes pst) ps psTypes +-- in foldr ($) w' fs +--{- | -} +--updateSpot :: World -> PlacementSpot -> (World, PSType) +--updateSpot w ps = case _psType ps of +-- PutButton bt -> undefined +-- PutCrit cr -> placeUpdateCr cr p rot w +-- where +-- p = _psPos ps +-- rot = _psRot ps +{- | -} placeSpot :: PlacementSpot -> World -> World placeSpot ps w = case _psType ps of PutButton bt -> placeBt bt p rot w @@ -134,7 +133,7 @@ addPane wl (p0,p1) wls = IM.insert (newKey wls) (wl }) wls -placeBt bt p rot w = over buttons addBT w +placeBt bt p rot = over buttons addBT where addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts {- Creates a floor item at a given point. @@ -155,7 +154,7 @@ placeFlIt itm p rot = floorItems %~ } ) fis -placePressPlate pp p rot w = over pressPlates addPP w +placePressPlate pp p rot = over pressPlates addPP where addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps @@ -166,20 +165,21 @@ placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr) cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} placeCr :: Creature -> Point2 -> Float -> World -> World -placeCr crF p rot w = over creatures addCr w +placeCr crF p rot = over creatures addCr where - addCr crs = IM.insert (newKey crs) + addCr crs = IM.insert + (newKey crs) (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs}) crs placeLS :: LightSource -> Picture -> Point2 -> Float -> World -> World -placeLS ls dec p rot w = over lightSources addLS - $ over decorations addDec w - where addLS lss = IM.insert (newKey lss) - (ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss}) - lss - addDec decs = IM.insert (newKey decs) - (uncurry translate p $ rotate (0 - rot) dec) - decs - - +placeLS ls dec p rot w = over lightSources addLS $ over decorations addDec w + where + addLS lss = IM.insert + (newKey lss) + (ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss}) + lss + addDec decs = IM.insert + (newKey decs) + (uncurry translate p $ rotate (negate rot) dec) + decs diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index d678124cf..2d3f63d48 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -8,7 +8,6 @@ import Picture import Control.Lens import Control.Monad.State import System.Random - data PSType = PutCrit {_unPutCrit :: Creature} | PutLS LightSource Picture | PutButton Button @@ -34,12 +33,13 @@ data Placement = SinglePlacement {_placementSpot :: PlacementSpot } | GroupedPlacement {_groupPlacementID :: Int - ,_groupPlacementFunc :: [PSType] -> PSType -> World -> World +-- ,_groupPlacementUpdate :: World -> Placement -> (World, Placement) + ,_groupUpdate :: World -> [Placement] -> World +-- ,_groupPlacementFunc :: [PSType] -> PSType -> World -> World ,_placementSpot :: PlacementSpot } - +sPS :: Point2 -> Float -> PSType -> Placement sPS p a = SinglePlacement . PS p a - makeLenses ''PSType makeLenses ''PlacementSpot makeLenses ''Placement diff --git a/src/Dodge/LevelGen/SwarmPlacement.hs b/src/Dodge/LevelGen/SwarmPlacement.hs index 944108239..9b44c96be 100644 --- a/src/Dodge/LevelGen/SwarmPlacement.hs +++ b/src/Dodge/LevelGen/SwarmPlacement.hs @@ -3,23 +3,54 @@ module Dodge.LevelGen.SwarmPlacement ) where import Dodge.Data +import Dodge.Base import Dodge.LevelGen.Data import Dodge.Creature.State.Data +import Geometry +import Data.List import qualified Data.IntSet as IS +import qualified Data.IntMap as IM import Control.Lens swarmPS :: Int -> Point2 -> Float -> Creature -> Placement swarmPS i p a cr = GroupedPlacement { _groupPlacementID = i - , _groupPlacementFunc = setSwarm + , _groupUpdate = setSwarm +-- , _groupPlacementFunc = setSwarm i , _placementSpot = PS p a $ PutCrit cr } - -setSwarm :: [PSType] -> PSType -> World -> World -setSwarm psts (PutCrit cr) w - = w & creatures . ix cid . crGroup .~ theSwarm +setSwarm :: World -> [Placement] -> World +setSwarm w ps = updateCrs w' & creatureGroups %~ IM.insert gid theGroupParams where - cid = _crID cr - theSwarm = Swarm swarmSet - swarmSet = IS.fromList $ map (_crID . _unPutCrit) psts + (w', crs) = mapAccumR updateCrit w ps + is = IS.fromList $ map _crID crs + cpos = centroid $ map _crPos crs + gid = newKey (_creatureGroups w') + theGroupParams = CrGroupParams + { _crGroupParamID = gid + , _crGroupIDs = is + , _crGroupCenter = cpos + , _crGroupUpdate = crGroupUpdateCenter + } + updateCrs w'' = IS.foldl' (\w''' cid -> w''' & creatures . ix cid %~ setSwarmStatus) w'' is + setSwarmStatus = crGroup .~ Swarm {_swarm = is, _crGroupID = gid} + +crGroupUpdateCenter :: World -> CrGroupParams -> Maybe CrGroupParams +crGroupUpdateCenter w cgp + | IM.null crs = Nothing + | otherwise = Just $ cgp & crGroupCenter .~ + centroid (IM.map _crPos crs) + where + crs = IM.restrictKeys (_creatures w) (_crGroupIDs cgp) + +updateCrit :: World -> Placement -> (World, Creature) +updateCrit w pl = (w & creatures %~ IM.insert cid cr + , cr + ) + where + p = _psPos $ _placementSpot pl + rot = _psRot $ _placementSpot pl + scr = _unPutCrit $ _psType $ _placementSpot pl + cid = newKey (_creatures w) + cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} diff --git a/src/Dodge/LightSources.hs b/src/Dodge/LightSources.hs index e41ddc3d0..4829f4ac5 100644 --- a/src/Dodge/LightSources.hs +++ b/src/Dodge/LightSources.hs @@ -50,4 +50,4 @@ tLightRad i rmax rmin p = TLS , _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p) } -tLightAt i p = tLightRad i 100 0 p +tLightAt i = tLightRad i 100 0 diff --git a/src/Dodge/LoadSound.hs b/src/Dodge/LoadSound.hs index e3e78790b..d21881bb3 100644 --- a/src/Dodge/LoadSound.hs +++ b/src/Dodge/LoadSound.hs @@ -1,17 +1,13 @@ module Dodge.LoadSound where --- imports {{{ import Dodge.Data import Data.Maybe import qualified Data.IntMap.Strict as IM import qualified Data.Map as M - import Control.Monad import Control.Lens - import qualified SDL.Mixer as Mix --- }}} loadSounds :: IO (IM.IntMap Mix.Chunk) loadSounds = do Mix.openAudio Mix.defaultAudio 128 @@ -57,7 +53,7 @@ loadSounds = do glass3' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A3.wav" glass4' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A4.wav" foamSpray' <- Mix.load "./data/sound/foamSprayLoop.wav" - return $ IM.fromList $ zip [0..] $ + return $ IM.fromList $ zip [0..] [ pFireSound , click , reloadSound' @@ -105,6 +101,6 @@ loadSounds = do loadMusic :: IO (IM.IntMap Mix.Music) loadMusic = do undercity <- Mix.load "./data/music/firstCompo.mid" - return $ IM.fromList $ zip [0..] $ + return $ IM.fromList $ zip [0..] [ undercity ] diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index 6fdce52cd..e3132cc94 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -41,31 +41,24 @@ type SearchedNodes = (HP.MinHeap (Float,(Float,[Point2])), [Point2]) stripRight :: Either a b -> b stripRight (Right x) = x -stepPath :: (Point2 -> [Point2]) -> Point2 - -> SearchedNodes -> Either [Point2] SearchedNodes -stepPath f p (nextNodes, seenNodes) - = case HP.view nextNodes of - Nothing -> Left [] - Just ((_,(cost,(q:qs))), nextNodes') - | q == p -> Left (q:qs) - | otherwise -> let rs' = f q - rs = rs' \\ seenNodes - newNodes = map (\r -> (cost + dist q r + dist r p - , (cost + dist q r - , (r:q:qs) - ) - ) - ) rs - in Right $ (foldr HP.insert nextNodes' newNodes - , rs ++ seenNodes - ) -stepPath' :: (Point2 -> [Point2]) -> Point2 - -> SearchedNodes -> [Point2] -stepPath' f p s = case stepPath f p s of Left ps -> ps - Right s' -> stepPath' f p s' +stepPath :: (Point2 -> [Point2]) -> Point2 -> SearchedNodes -> Either [Point2] SearchedNodes +stepPath f p (nextNodes, seenNodes) = case HP.view nextNodes of + Nothing -> Left [] + Just ((_,(cost,q:qs)), nextNodes') + | q == p -> Left (q:qs) + | otherwise -> + let rs' = f q + rs = rs' \\ seenNodes + newNodes = map (\r -> (cost + dist q r + dist r p , (cost + dist q r , r:q:qs))) rs + in Right (foldr HP.insert nextNodes' newNodes , rs ++ seenNodes) + +stepPath' :: (Point2 -> [Point2]) -> Point2 -> SearchedNodes -> [Point2] +stepPath' f p s = case stepPath f p s of + Left ps -> ps + Right s' -> stepPath' f p s' makePath' :: (Point2 -> [Point2]) -> Point2 -> Point2 -> [Point2] -makePath' f s e = stepPath' f e $ (HP.singleton (0,(0,[s])) , []) +makePath' f s e = stepPath' f e (HP.singleton (0,(0,[s])) , []) makeNode :: Point2 -> SearchedNodes makeNode e = (HP.singleton (0,(0,[e])) , []) @@ -76,39 +69,36 @@ tp1 = (0,1) tp2 = (0,20) tp3 = (30,40) -f = incidenceToFunction $ pairsToIncidence [(tp1,tp2),(tp2,tp3) - ,(tp2,tp1) - ,(tp1,tp3)] -g = pairsToIncidence [(tp1,tp2),(tp2,tp3) - ,(tp2,tp1) - ,(tp1,tp3)] +f = incidenceToFunction $ pairsToIncidence + [(tp1,tp2) + ,(tp2,tp3) + ,(tp2,tp1) + ,(tp1,tp3) + ] +g = pairsToIncidence + [(tp1,tp2) + ,(tp2,tp3) + ,(tp2,tp1) + ,(tp1,tp3) + ] pathBetween :: Point2 -> Point2 -> World -> Maybe [Point2] -pathBetween a b w = makePath' <$> return (\p -> _pathInc w M.! p) <*> a' <*> b' - where - nsa :: [Point2] - nsa = map snd $ concat $ lookLookups (zoneAroundPoint a) (_pathPoints w) - nsb = map snd $ concat $ lookLookups (zoneAroundPoint b) (_pathPoints w) - --a' = listToMaybe $ sortBy (compare `on` dist a) $ ns - --b' = listToMaybe $ sortBy (compare `on` dist b) $ ns - a' = listToMaybe $ filter (flip (isWalkable a) w) nsa - b' = listToMaybe $ filter (flip (isWalkable b) w) nsb - - - ----- +pathBetween a b w = (makePath' $ \p -> _pathInc w M.! p) <$> a' <*> b' + where + nsa :: [Point2] + nsa = map snd $ concat $ lookLookups (zoneAroundPoint a) (_pathPoints w) + nsb = map snd $ concat $ lookLookups (zoneAroundPoint b) (_pathPoints w) + a' = find (flip (isWalkable a) w) nsa + b' = find (flip (isWalkable b) w) nsb makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] makePathBetween a b w = join $ sp <$> fmap fst a' <*> fmap fst b' <*> return g - where g = _pathGraph w - nsa = concat $ lookLookups (zoneAroundPoint a) (_pathPoints w) - nsb = concat $ lookLookups (zoneAroundPoint b) (_pathPoints w) --- a' = listToMaybe $ sortBy (compare `on` dist a . snd) $ filter (flip (isWalkable a) w . snd) ns --- b' = listToMaybe $ sortBy (compare `on` dist b . snd) $ filter (flip (isWalkable b) w . snd) ns - a' = listToMaybe $ filter (flip (isWalkable a) w . snd) nsa - b' = listToMaybe $ filter (flip (isWalkable b) w . snd) nsb - - + where + g = _pathGraph w + nsa = concat $ lookLookups (zoneAroundPoint a) (_pathPoints w) + nsb = concat $ lookLookups (zoneAroundPoint b) (_pathPoints w) + a' = find (flip (isWalkable a) w . snd) nsa + b' = find (flip (isWalkable b) w . snd) nsb ezipWith :: Monoid a => (b -> c -> d) -> Either a b -> Either a c -> Either a d ezipWith f (Right x) (Right y) = Right (f x y) @@ -116,46 +106,38 @@ ezipWith f (Left x) (Right _) = Left x ezipWith f (Right _) (Left y) = Left y ezipWith f (Left x) (Left y) = Left (mappend x y) - makePathBetween' :: Point2 -> Point2 -> World -> Either String [Int] -makePathBetween' a b w = let g = _pathGraph w - ns = labNodes g - nsa = (_pathPoints w) `ixNZ` a - nsb = (_pathPoints w) `ixNZ` b - a' = case listToMaybe $ sortBy (compare `on` dist a . snd) - -- a' = case listToMaybe - $ filter (flip (isWalkable a) w . snd) ns of - Just p -> Right $ fst p - _ -> Left "FIRST POINT UNSEEN" - b' = case listToMaybe $ sortBy (compare `on` dist b . snd) - -- b' = case listToMaybe - $ filter (flip (isWalkable b) w . snd) ns of - Just p -> Right $ fst p - _ -> Left $ "SECOND POINT UNSEEN" ++ show b - in case ezipWith (\x y -> sp x y g) a' b' of - Right (Just xs) -> Right xs - Right (Nothing) -> Left $ "NO PATH" ++ show a ++ show b ++ show a' ++ show b' - Left m -> Left m +makePathBetween' a b w = + let g = _pathGraph w + ns = labNodes g + nsa = _pathPoints w `ixNZ` a + nsb = _pathPoints w `ixNZ` b + a' = case listToMaybe $ sortBy (compare `on` dist a . snd) $ filter (flip (isWalkable a) w . snd) ns of + Just p -> Right $ fst p + _ -> Left "FIRST POINT UNSEEN" + b' = case listToMaybe $ sortBy (compare `on` dist b . snd) $ filter (flip (isWalkable b) w . snd) ns of + Just p -> Right $ fst p + _ -> Left $ "SECOND POINT UNSEEN" ++ show b + in case ezipWith (\x y -> sp x y g) a' b' of + Right (Just xs) -> Right xs + Right Nothing -> Left $ "NO PATH" ++ show a ++ show b ++ show a' ++ show b' + Left m -> Left m makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2] ---makePathBetweenPs a b = pathBetween a b -makePathBetweenPs a b w = fmap (mapMaybe (lab g)) $ makePathBetween b a w - where g = _pathGraph w +makePathBetweenPs a b w = mapMaybe (lab g) <$> makePathBetween b a w + where + g = _pathGraph w makePathBetweenPs' :: Point2 -> Point2 -> World -> Either String [Point2] -makePathBetweenPs' a b w = fmap (mapMaybe (lab g)) $ makePathBetween' a b w - where g = _pathGraph w - +makePathBetweenPs' a b w = mapMaybe (lab g) <$> makePathBetween' a b w + where + g = _pathGraph w pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2 -pointTowardsImpulse a b w = join $ fmap (listToMaybe . filter (flip (isWalkable a) w)) --- $ pathBetween a b w - $ makePathBetweenPs a b w --- +pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a b w pointTowardsImpulse' :: Point2 -> Point2 -> World -> Either String Point2 -pointTowardsImpulse' a b w = join $ fmap (maybeToEither "NOSEEPATH" . listToMaybe . filter (flip (isWalkable a) w)) - $ makePathBetweenPs' b a w +pointTowardsImpulse' a b w = (maybeToEither "NOSEEPATH" . find (flip (isWalkable a) w)) =<< makePathBetweenPs' b a w maybeToEither :: a -> Maybe b -> Either a b maybeToEither _ (Just x) = Right x diff --git a/src/Dodge/RandomHelp.hs b/src/Dodge/RandomHelp.hs index 34c2a68a7..47d5c5dea 100644 --- a/src/Dodge/RandomHelp.hs +++ b/src/Dodge/RandomHelp.hs @@ -12,7 +12,7 @@ import Data.List randomRanges :: (Random a,RandomGen g) => [a] -> State g a randomRanges xs = join $ takeOne $ f xs where - f (x:y:ys) = (state (randomR (x,y))) : (f ys) + f (x:y:ys) = state (randomR (x,y)) : f ys f _ = [] takeOne :: RandomGen g => [a] -> State g a @@ -20,7 +20,7 @@ takeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (xs !! i)) takeOneWeighted :: (RandomGen g, Random b, Ord b, Num b) => [b] -> [a] -> State g a takeOneWeighted ws xs = state (randomR (0, sum ws)) - >>= (\w -> return (xs !! (i w ws))) + >>= (\w -> return (xs !! i w ws)) where i y (z:zs) | y <= z = 0 @@ -35,11 +35,11 @@ takeOneMore (xs,ys) = do return (w:xs, zs ++ ws) takeNMore :: RandomGen g => Int -> ([a],[a]) -> State g ([a],[a]) -takeNMore n p = foldr (const ((=<<) takeOneMore)) (return p) [1..n] +takeNMore n p = foldr (const (>>= takeOneMore)) (return p) [1..n] takeN :: RandomGen g => Int -> [a] -> State g [a] takeN 0 xs = return [] -takeN i xs = fmap fst $ takeNMore i ([],xs) +takeN i xs = fst <$> takeNMore i ([],xs) -- | Randomly shuffle a list. shuffle :: RandomGen g => [a] -> State g [a] diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index a35087119..a241cf296 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -38,7 +38,7 @@ import qualified SDL Central drawing function. Returns a 'Word32' that should give the number of ticks it took to evaluate. -} -doDrawing :: RenderData -> World -> IO (Word32) +doDrawing :: RenderData -> World -> IO Word32 doDrawing pdata w = do sTicks <- SDL.ticks clear [ColorBuffer,DepthBuffer] diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 56aa8f744..23fd9cd5a 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -169,8 +169,10 @@ ffToDraw w = filter (lineOnScreen w . _ffLine) $ _forceFields w drawFF :: ForceField -> Picture -drawFF (FF {_ffLine = l, _ffColor = col}) = pictures [color white $ line l, color col - $ lineOfThickness 6 l ] +drawFF FF{_ffLine = l, _ffColor = col} = pictures + [color white $ line l + , color col $ lineOfThickness 6 l + ] drawFFShadow :: World -> ForceField -> [Picture] drawFFShadow w ff diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index 12d591c38..f8272df77 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -84,10 +84,8 @@ roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2 f a x b y = putBlockRect a x b y g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d - - branchWith :: Room -> [Tree Room] -> Tree (Either Room Room) -branchWith r ts = Node (Left r) $ [return $ Right door] ++ fmap (fmap Left) ts +branchWith r ts = Node (Left r) $ return (Right door) : fmap (fmap Left) ts glassSwitchBack :: RandomGen g => State g Room glassSwitchBack = do @@ -95,16 +93,17 @@ glassSwitchBack = do hgt <- state $ randomR (400,600) wllen <- state $ randomR (60,wth/2-40) let hf = hgt/5 - let plmnts = [windowLine (wth-60, hf) (wllen,hf) - ,windowLine (wth-wllen,2*hf) (60, 2*hf) - ,windowLine (wth-60, 3*hf) (wllen,3*hf) - ,windowLine (wth-wllen,4*hf) (60, 4*hf) - ,blockLine ( 0, 1*hf) (wllen,1*hf) - ,blockLine (wth-wllen, 2*hf) ( wth,2*hf) - ,blockLine ( 0, 3*hf) (wllen,3*hf) - ,blockLine (wth-wllen, 4*hf) ( wth,4*hf) - , sPS (wth/2,hgt/2) 0 $ putLamp - ] + let plmnts = + [windowLine (wth-60, hf) (wllen,hf) + ,windowLine (wth-wllen,2*hf) (60, 2*hf) + ,windowLine (wth-60, 3*hf) (wllen,3*hf) + ,windowLine (wth-wllen,4*hf) (60, 4*hf) + ,blockLine ( 0, 1*hf) (wllen,1*hf) + ,blockLine (wth-wllen, 2*hf) ( wth,2*hf) + ,blockLine ( 0, 3*hf) (wllen,3*hf) + ,blockLine (wth-wllen, 4*hf) ( wth,4*hf) + , sPS (wth/2,hgt/2) 0 putLamp + ] return $ set rmPS plmnts $ roomRect wth hgt 2 6 manyDoors :: Int -> Tree (Either Room Room) @@ -112,22 +111,22 @@ manyDoors i = treeFromPost (replicate i (Left door)) $ Right door glassLesson :: RandomGen g => State g (Tree (Either Room Room)) glassLesson = do - corridors <- sequence $ replicate 3 $ fmap Left $ randomiseOutLinks corridor - return $ Node (Left $ botRoom) [deadRoom door,uppers, treeFromPost (Left door : corridors) $ Right door] - where uppers = Node (Left door) [deadRoom topRoom] - botRoom = set rmPS botplmnts - $ roomRect 200 200 1 1 - topRoom = set rmPS topplmnts - $ roomRect 200 200 1 1 - botplmnts = [sPS (0,0) 0 $ PutWall (rectNSWE (200) 0 (90) (110)) - $ defaultCrystalWall - ,sPS (50,100) 0 $ PutCrit miniGunCrit - ,sPS (50,50) 0 putLamp - ] - topplmnts = [windowLine (100,200) (100,0) - ,sPS (50,100) 0 $ PutCrit miniGunCrit - ,sPS (50,50) 0 putLamp - ] + corridors <- replicateM 3 $ Left <$> randomiseOutLinks corridor + return $ Node (Left botRoom) [deadRoom door,uppers, treeFromPost (Left door : corridors) $ Right door] + where + uppers = Node (Left door) [deadRoom topRoom] + botRoom = set rmPS botplmnts $ roomRect 200 200 1 1 + topRoom = set rmPS topplmnts $ roomRect 200 200 1 1 + botplmnts = + [sPS (0,0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall + ,sPS (50,100) 0 $ PutCrit miniGunCrit + ,sPS (50,50) 0 putLamp + ] + topplmnts = + [windowLine (100,200) (100,0) + ,sPS (50,100) 0 $ PutCrit miniGunCrit + ,sPS (50,50) 0 putLamp + ] miniRoom1 :: RandomGen g => State g Room miniRoom1 = do @@ -145,7 +144,7 @@ miniRoom1 = do ,windowLine (wth-60, 40+3*hf) (wllen,40+3*hf) ,windowLine (wth-wllen,40+4*hf) (60,40+4*hf) ,sPS (crx,cry) 0 $ PutCrit miniGunCrit - ,sPS (wth-20,hgt/2+40) 0 $ randC + ,sPS (wth-20,hgt/2+40) 0 randC ,sPS (wth/2,hgt/2) 0 putLamp ,blockLine ( 0, 40+1*hf) (wllen,40+1*hf) ,blockLine (wth-wllen, 40+2*hf) ( wth,40+2*hf) @@ -155,9 +154,10 @@ miniRoom1 = do return $ set rmPS plmnts $ shiftRoomBy ((0,40),0) $ roomRect wth hgt 2 4 miniTree2 :: RandomGen g => State g (Tree (Either Room Room)) -miniTree2 = miniRoom1 >>= randomiseOutLinks >>= changeLinkTo (\p -> (snd . fst) p < 70) - >>= return . flip branchWith (replicate 3 $ treeFromPost [door,corridor] - critInDeadEnd ) +miniTree2 = miniRoom1 + >>= randomiseOutLinks + >>= changeLinkTo (\p -> (snd . fst) p < 70) + <&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd) miniRoom3 :: RandomGen g => State g (Tree (Either Room Room)) miniRoom3 = do @@ -200,7 +200,7 @@ roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treeFromPost [return $ connectRoom door ,join $ takeOne [miniTree2,glassLesson] ] - $ fmap connectRoom $ randomiseOutLinks corridor + $ connectRoom <$> randomiseOutLinks corridor where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs @@ -245,7 +245,7 @@ allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y] randomCorridorFrom :: RandomGen g => [a] -> State g (Tree (Either a a)) randomCorridorFrom xs = do - rooms <- sequence $ replicate 5 $ takeOne xs + rooms <- replicateM 5 $ takeOne xs return $ treeFromTrunk (map Left $ init rooms) (Node (Right (last rooms)) []) {- Probabilites of the type of the first floor weapon. -} randFirstWeapon :: State StdGen PSType @@ -264,23 +264,25 @@ weaponEmptyRoom :: RandomGen g => State g (Tree (Either Room Room)) weaponEmptyRoom = do w <- state $ randomR (220,300) h <- state $ randomR (220,300) - let plmnts = [sPS (w/2,h-40) 0 $ RandPS randFirstWeapon - ,sPS (20,20) (pi/2) $ randC1 - ,sPS (w-20,20) (pi/2) $ randC1 - ,sPS (w/2,h/2) 0 $ putLamp - ] - (fmap connectRoom . randomiseOutLinks) =<< (changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst) - $ set rmPS plmnts $ roomRect w h 2 2) + let plmnts = + [sPS (w/2,h-40) 0 $ RandPS randFirstWeapon + ,sPS (20,20) (pi/2) randC1 + ,sPS (w-20,20) (pi/2) randC1 + ,sPS (w/2,h/2) 0 putLamp + ] + (fmap connectRoom . randomiseOutLinks) =<< + changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst) (set rmPS plmnts $ roomRect w h 2 2) weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room)) weaponUnderCrits = do let plmnts = - [sPS (20,0) 0 $ RandPS randFirstWeapon - ,sPS (20,0) (0-pi/2) $ randC1 - ,sPS (20,20) (0-pi/2) $ randC1 + [sPS (20,0) 0 $ RandPS randFirstWeapon + ,sPS (20,0) (negate $ pi/2) randC1 + ,sPS (20,20) (negate $ pi/2) randC1 ] - let continuationRoom = treeFromTrunk [Left corridorN,Left corridorN] - (connectRoom (set rmPS plmnts $ corridorN)) + let continuationRoom = treeFromTrunk + [Left corridorN,Left corridorN] + (connectRoom (set rmPS plmnts corridorN)) rcp' <- roomCenterPillar let rcp = over rmPS ( sPS (120,80) 0 putLamp : ) rcp' deadEndRoom <- takeOne [roomPillars,rcp] @@ -295,14 +297,16 @@ weaponBehindPillar :: RandomGen g => State g (Tree (Either Room Room)) weaponBehindPillar = do crPos <- takeOne $ [(x,y) | x <- [20,220], y <- [20,220]] ++ [(120,160),(120,200)] let d p = argV $ (120,80) -.- p - let plmnts1 = [sPS (120,160) 0 $ RandPS randFirstWeapon - ,sPS crPos (d crPos) $ randC1 - ] + let plmnts1 = + [sPS (120,160) 0 $ RandPS randFirstWeapon + ,sPS crPos (d crPos) randC1 + ] rcp <- roomCenterPillar - return $ treeFromTrunk [Left door - ,Left $ over rmLinks tail $ over rmPS (++ plmnts1) rcp] - (connectRoom $ set rmPS [sPS (20,60) (0-pi/2) $ randC1] - $ corridorN) + return $ treeFromTrunk + [Left door + ,Left $ over rmLinks tail $ over rmPS (++ plmnts1) rcp + ] + (connectRoom $ set rmPS [sPS (20,60) (negate $ pi/2) randC1] corridorN) weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room)) weaponBetweenPillars = do @@ -313,34 +317,31 @@ weaponBetweenPillars = do d p = argV $ (120,120) -.- p plmnts = [sPS wpPos 0 $ RandPS randFirstWeapon - ,sPS crPos1 (d crPos1) $ randC1 - ,sPS crPos2 (d crPos2) $ randC1 + ,sPS crPos1 (d crPos1) randC1 + ,sPS crPos2 (d crPos2) randC1 ] - (fmap connectRoom . randomiseOutLinks) =<< (filterLinks f $ over rmPS (++plmnts) $ roomPillars) + (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (over rmPS (++plmnts) roomPillars) where f (_,a) = a == 0 weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room)) weaponLongCorridor = do - root <- takeOne $ [tEast, tWest] + root <- takeOne [tEast, tWest] connectingRoom <- takeOne - [tEast & rmPS .~ [sPS (-40,60) 0 $ putLamp] - ,tWest & rmPS .~ [sPS ( 40,60) 0 $ putLamp] + [tEast & rmPS .~ [sPS (-40,60) 0 putLamp] + ,tWest & rmPS .~ [sPS ( 40,60) 0 putLamp] ] i1 <- state $ randomR (2,5) i2 <- state $ randomR (2,5) let branch1 = treeFromTrunk (replicate i1 $ Left corridorN) (connectRoom $ putCrs connectingRoom) let branch2 = treeFromTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor) return $ Node (Left root) [branch1,branch2] - where putCrs = over rmPS (++ [sPS (10,40) (-pi/2) $ randC - ,sPS (-10,40) (-pi/2) $ randC - ]) - putWp = set rmPS [sPS (20,40) 0 $ RandPS randFirstWeapon - ,sPS (20,60) 0 $ putLamp - ] + where + putCrs = over rmPS (++ [sPS (10,40) (-pi/2) randC ,sPS (-10,40) (-pi/2) randC ]) + putWp = set rmPS [sPS (20,40) 0 $ RandPS randFirstWeapon ,sPS (20,60) 0 putLamp ] critInDeadEnd :: Room -critInDeadEnd = set rmPS [sPS (0,0) 0 $ randC] deadEndRoom +critInDeadEnd = set rmPS [sPS (0,0) 0 randC] deadEndRoom deadEndRoom :: Room deadEndRoom = Room @@ -365,8 +366,8 @@ weaponRoom = join $ takeOne roomCCrits :: RandomGen g => State g (Tree (Either Room Room)) roomCCrits = do - ps <- sequence $ replicate 20 $ randInCirc 9 - let plmnts = map (\p -> sPS p 0 $ randC) + ps <- replicateM 20 $ randInCirc 9 + let plmnts = map (\p -> sPS p 0 randC) $ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps lamps = [sPS (50,100) 0 putLamp , sPS (175,100) 0 putLamp] return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200 @@ -384,38 +385,33 @@ longRoom = do ,rectNSWE (h-35) (h-135) 65 85 ] let wsDefense = map (\ps -> sPS (0,0) 0 $ PutWall ps defaultCrystalWall) - [rectNSWE (95) (70) 0 25 - ,rectNSWE (95) (70) 50 75 + [rectNSWE 95 70 0 25 + ,rectNSWE 95 70 50 75 ] brls <- fmap (map (\p -> sPS (p +.+ (10,200)) 0 $ PutCrit explosiveBarrel) ) - $ sequence $ replicate 5 $ randInRect (w-20) 900 + $ replicateM 5 $ randInRect (w-20) 900 let rm = roomRect w (h+70) 1 1 & rmPolys %~ ([rectNSWE h (h-165) (-45) (w+45)] ++) - changeLinkTo cond $ set rmPS (ws ++ brls ++ wsDefense ++ - [sPS ( 12.5,h-25) 0 $ PutCrit longCrit - ,sPS ( 37.5,h-25) 0 $ PutCrit longCrit - ,sPS ( 62.5,h-25) 0 $ PutCrit longCrit - ,sPS ( 25, 20) 0 $ putLamp - ,sPS ( 25, h-10) 0 $ putLamp - ] - ) - $ rm - + changeLinkTo cond $ rm & rmPS .~ ws ++ brls ++ wsDefense ++ + [sPS ( 12.5,h-25) 0 $ PutCrit longCrit + ,sPS ( 37.5,h-25) 0 $ PutCrit longCrit + ,sPS ( 62.5,h-25) 0 $ PutCrit longCrit + ,sPS ( 25, 20) 0 putLamp + ,sPS ( 25,h-10) 0 putLamp + ] shooterRoom :: RandomGen g => State g Room shooterRoom = do h <- state $ randomR (200,300) let cond x = (snd . fst) x < h - 40 - changeLinkTo cond $ set rmPS ( [blockLine (50,50) (50,h) - ,sPS ( 25,h-25) 0 $ PutCrit $ addArmour autoCrit - ,sPS ( 75,h-30) 0 $ PutCrit explosiveBarrel - ,sPS ( 75,h-60) 0 $ PutCrit explosiveBarrel - ,sPS ( 85,h-10) 0 $ PutCrit explosiveBarrel - ,sPS ( 85,h-45) 0 $ PutCrit explosiveBarrel - ,sPS ( 75,h-80) 0 putLamp - ] - ) - $ roomRect 100 h 1 1 - + changeLinkTo cond $ roomRect 100 h 1 1 & rmPS .~ + [blockLine (50,50) (50,h) + ,sPS ( 25,h-25) 0 $ PutCrit $ addArmour autoCrit + ,sPS ( 75,h-30) 0 $ PutCrit explosiveBarrel + ,sPS ( 75,h-60) 0 $ PutCrit explosiveBarrel + ,sPS ( 85,h-10) 0 $ PutCrit explosiveBarrel + ,sPS ( 85,h-45) 0 $ PutCrit explosiveBarrel + ,sPS ( 75,h-80) 0 putLamp + ] shootersRoom1 :: RandomGen g => State g Room shootersRoom1 = do diff --git a/src/Dodge/SoundLogic.hs b/src/Dodge/SoundLogic.hs index 08f1548dc..36067b03d 100644 --- a/src/Dodge/SoundLogic.hs +++ b/src/Dodge/SoundLogic.hs @@ -70,13 +70,13 @@ resumeSound w = w Consider replacing instances with 'soundOncePos'. -} soundOnce :: Int -> World -> World -soundOnce i = over soundQueue ((:) (i,0)) +soundOnce i = soundQueue %~ ((i,0) : ) {-| Play a sound with a given position in the world. Uses the angle between the given position and '_cameraViewFrom', taking into account '_cameraRot'. -} soundOncePos :: Int -> Point2 -> World -> World -soundOncePos i pos w = over soundQueue ((:) (i,a)) w +soundOncePos i pos w = w & soundQueue %~ ((i,a) :) where a = soundAngle pos w @@ -88,7 +88,7 @@ soundOnceOrigin -> SoundOrigin -- ^ The \"creator\" of the sound -> Point2 -- ^ The position of the sound in the world -> World -> World -soundOnceOrigin sType so p w = over sounds (M.insertWith (flip const) so theSound) w +soundOnceOrigin sType so p w = w & sounds %~ M.insertWith (\ _ x -> x) so theSound where theSound = Sound { _soundChunkID = sType @@ -141,7 +141,7 @@ soundFrom -> Int -- ^ Frames to play -> Int -- ^ Fade out time (ms) -> World -> World -soundFrom so sType time fadeTime w = over sounds (M.insertWith f so sound) w +soundFrom so sType time fadeTime = sounds %~ M.insertWith f so sound where sound = Sound { _soundChunkID = sType diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 8bf9ae70d..3d1ced58f 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -9,7 +9,6 @@ import Dodge.Data import Dodge.Data.Menu import Dodge.World.Trigger.Data import Dodge.Config.Data -import Dodge.Data.Menu import Dodge.Base import Dodge.WallCreatureCollisions import Dodge.LevelGen.Block @@ -67,6 +66,7 @@ update' w = case _menuLayers w of . zoneClouds . updateClouds . updateCreatures + . updateCreatureGroups . updateBlocks . updateSeenWalls . updateSoundQueue @@ -84,6 +84,10 @@ update' w = case _menuLayers w of cid = _clID cr doubleArgumentFor f x = f x x +updateCreatureGroups :: World -> World +updateCreatureGroups w = w & creatureGroups %~ + IM.mapMaybe (\cgp -> _crGroupUpdate cgp w cgp) + updateTriggers :: World -> World updateTriggers w | ResetLevel 1 `S.member` _worldTriggers w = generateFromList levx $ initialWorld @@ -119,7 +123,7 @@ updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w {- | Apply door mechanisms. -} updateWalls :: World -> World -updateWalls w = IM.foldr (maybe id id . (^? doorMech)) w (_walls w) +updateWalls w = IM.foldr (fromMaybe id . (^? doorMech)) w (_walls w) ppEvents :: World -> World ppEvents w = IM.foldr (\pp w -> _ppEvent pp pp w) w $ _pressPlates w @@ -158,8 +162,8 @@ moveCloud c w = _clEffect c c . theUpdate $ w oldPos = _clPos c newPos = oldPos +.+ newVel hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w - finalPos = fromMaybe newPos (fmap fst hitWl) - finalVel = fromMaybe newVel (fmap snd hitWl) + finalPos = maybe newPos fst hitWl + finalVel = maybe newVel snd hitWl theUpdate w' = w' & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1) & clouds . ix (_clID c) . clVel .~ finalVel @@ -168,7 +172,7 @@ moveCloud c w = _clEffect c c . theUpdate $ w clClSpringVel :: Cloud -> World -> Cloud -> Point2 -> Point2 clClSpringVel a w b v | ida == idb = v - | dist pa pb < radDist = v +.+ 0.1 *.* (safeNormalizeV (pa -.- pb)) + | dist pa pb < radDist = v +.+ 0.1 *.* safeNormalizeV (pa -.- pb) | otherwise = v where ida = _clID a @@ -181,7 +185,7 @@ simpleCrSprings :: World -> World simpleCrSprings w = IM.foldr' crSpring w $ _creatures w crSpring :: Creature -> World -> World -crSpring c w = IM.foldr' (crCrSpring c) w $ cs +crSpring c w = IM.foldr' (crCrSpring c) w cs where cs = creaturesNearPoint (_crPos c) w @@ -196,7 +200,7 @@ crCrSpring c1 c2 w id1 = _crID c1 id2 = _crID c2 vec = _crPos c1 -.- _crPos c2 - diff = magV $ vec + diff = magV vec comRad = _crRad c1 + _crRad c2 overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index 14c7a10f0..e4bb9ae90 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -27,7 +27,7 @@ colCrWall w c rad = _crRad c + wallBuffer p1 = _crOldPos c p2 = _crPos c - ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w + ls = IM.elems $ _wlLine <$> wallsNearPoint p2 w wallPoints = nub $ concatMap (\(x,y) -> [x,y]) ls -- colCrPushThrough :: World -> Creature -> Creature @@ -65,13 +65,13 @@ pushOrCrush :: [(Point2,Point2)] -> Creature -> Creature pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of [] -> cr [p] -> cr & crPos .~ p - _ -> cr & crState . crDamage %~ ( (Blunt 50 cpos cpos cpos) :) + _ -> cr & crState . crDamage %~ ( Blunt 50 cpos cpos cpos : ) where cpos = _crPos cr -- assumes that the wall is orientated -- assumes wall points are different -pushOutFromWall :: Float -> Point2 -> (Point2,Point2) -> Maybe (Point2) +pushOutFromWall :: Float -> Point2 -> (Point2,Point2) -> Maybe Point2 pushOutFromWall rad cp2 (wp1,wp2) | isOnWall = Just newP -- +.+ (1 *.* norm)) | otherwise = Nothing @@ -88,7 +88,7 @@ pushOutFromCorners :: World -> Creature -> Creature pushOutFromCorners w cr = cr & crPos .~ newPos where newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls - ls = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ fmap _wlLine $ wallsNearPoint (_crPos cr) w + ls = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ _wlLine <$> wallsNearPoint (_crPos cr) w collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2 collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps @@ -103,7 +103,7 @@ checkPushThroughs :: Float -> Point2 -> [(Point2,Point2)] -> Point2 -> Point2 checkPushThroughs rad cp1 walls cp2 = fromMaybe cp2 $ (listToMaybe.mapMaybe (checkPushThrough rad cp1 cp2)) walls -checkPushThrough :: Float -> Point2 -> Point2 -> (Point2,Point2) -> Maybe (Point2) +checkPushThrough :: Float -> Point2 -> Point2 -> (Point2,Point2) -> Maybe Point2 checkPushThrough rad cp1 cp2 (wp1,wp2) | isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2 | otherwise = Nothing diff --git a/src/Dodge/WorldEvent.hs b/src/Dodge/WorldEvent.hs index fed86be63..f4b00f748 100644 --- a/src/Dodge/WorldEvent.hs +++ b/src/Dodge/WorldEvent.hs @@ -39,27 +39,27 @@ import Data.Function import Data.List import qualified Data.IntMap.Strict as IM -createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World -createBarrelSpark time colid pos dir maycid w = over worldEvents - ((.) $ ( over particles ((:) spark) - . sparkFlashAt pos') - ) w - where spark = Bul' { _ptDraw = drawBul - , _ptUpdate' = mvGenBullet' - , _btVel' = rotateV dir (5,0) - , _btColor' = numColor colid - , _btTrail' = [pos] - , _btPassThrough' = maycid - , _btWidth' = 1 - , _btTimer' = time - , _btHitEffect' = destroyOnImpact sparkEff noEff noEff - } - x = fst $ randomR (0,20) $ _randGen w - pos' = pos +.+ rotateV dir (x,0) - sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage) - ((:) $ SparkDam 1 sp p ep) - where sp = head (_btTrail' bt) - ep = sp +.+ _btVel' bt +createBarrelSpark :: Point2 -> Float -> Maybe Int -> Int -> Int -> World -> World +createBarrelSpark pos dir maycid time colid w + = over worldEvents (( over particles (spark :) . sparkFlashAt pos') . ) w + where + spark = Bul' + { _ptDraw = drawBul + , _ptUpdate' = mvGenBullet' + , _btVel' = rotateV dir (5,0) + , _btColor' = numColor colid + , _btTrail' = [pos] + , _btPassThrough' = maycid + , _btWidth' = 1 + , _btTimer' = time + , _btHitEffect' = destroyOnImpact sparkEff noEff noEff + } + x = fst $ randomR (0,20) $ _randGen w + pos' = pos +.+ rotateV dir (x,0) + sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ SparkDam 1 sp p ep) + where sp = head (_btTrail' bt) + ep = sp +.+ _btVel' bt diff --git a/src/Dodge/WorldEvent/Shockwave.hs b/src/Dodge/WorldEvent/Shockwave.hs index b0779a694..911611f45 100644 --- a/src/Dodge/WorldEvent/Shockwave.hs +++ b/src/Dodge/WorldEvent/Shockwave.hs @@ -72,7 +72,7 @@ mvShockwave is w pt t = _btTimer' pt tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt) rad = r - (3/4) * r * tFraction - dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks + dams = over creatures (IM.map damCr) . flip (IM.foldr damageBlocks) hitBlocks hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w damageBlocks wall w = case wall ^? blHP of diff --git a/src/DoubleStack.hs b/src/DoubleStack.hs index 870fac635..8ed55ddb0 100644 --- a/src/DoubleStack.hs +++ b/src/DoubleStack.hs @@ -17,17 +17,17 @@ left (DS (_,l,_)) = l right (DS (_,_,r)) = r pushL :: DS a -> DS a -pushL (DS (x,xs,(y:ys))) = DS (y,(x:xs),ys) +pushL (DS (x,xs, y:ys )) = DS (y, x:xs ,ys) pushL ds = ds pushR :: DS a -> DS a -pushR (DS (y,(x:xs),ys)) = DS (x,xs,(y:ys)) +pushR (DS (y, x:xs ,ys)) = DS (x,xs, y:ys ) pushR ds = ds cycleL :: DS a -> Maybe (DS a) -cycleL (DS (x,xs,(y:ys))) = Just $ DS (y,(x:xs),ys) +cycleL (DS (x,xs, y:ys )) = Just $ DS (y, x:xs ,ys) cycleL _ = Nothing cycleR :: DS a -> Maybe (DS a) -cycleR (DS (y,(x:xs),ys)) = Just $ DS (x,xs,(y:ys)) +cycleR (DS (y, x:xs ,ys)) = Just $ DS (x,xs, y:ys ) cycleR _ = Nothing diff --git a/src/Geometry.hs b/src/Geometry.hs index 26212aee5..c60ae534f 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -24,16 +24,13 @@ import Geometry.Vector import Data.Function import Data.List import Data.Maybe - import Control.Applicative - -- | Return a point a distance away from a first point towards a second point. -- Does not go past the second point. alongSegBy :: Float -> Point2 -> Point2 -> Point2 alongSegBy !x !a !b = a +.+ y *.* normalizeV (b -.- a) where y = min x $ dist a b - -- | Given a line and a point return the point on the line closest to the -- point. closestPointOnLine @@ -44,7 +41,6 @@ closestPointOnLine {-# INLINE closestPointOnLine #-} closestPointOnLine !a !b !p = a +.+ u *.* (b -.- a) where u = closestPointOnLineParam a b p - -- | Given a line and a point return a value corresponding to how far along the -- line the point is. closestPointOnLineParam @@ -55,36 +51,28 @@ closestPointOnLineParam {-# INLINE closestPointOnLineParam #-} closestPointOnLineParam !a !b !p = (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a) - -- | Draw a rectangle based on maximal N E S W values. rectNESW :: Float -> Float -> Float -> Float -> [Point2] rectNESW !a !b !c !d = [(b,a),(b,c),(d,c),(d,a) ] - -- | Draw a rectangle based on maximal N S E W values. rectNSEW :: Float -> Float -> Float -> Float -> [Point2] rectNSEW !n !s !e !w = rectNESW n e s w - -- | Draw a rectangle based on maximal N S W E values. rectNSWE :: Float -> Float -> Float -> Float -> [Point2] rectNSWE !n !s !w !e = [ (w,n), (w,s), (e,s), (e,n)] - +-- | Draw a rectangle around the origin with given height and width rectWdthHght :: Float -> Float -> [Point2] rectWdthHght w h = rectNSWE h (-h) (-w) w - --- | Draw a rectangle around the origin with given height and width - -- | Test whether a point is in a polygon or on the polygon border. -- Supposes the points in the -- polygon are listed in anticlockwise order. pointInOrOnPolygon :: Point2 -> [Point2] -> Bool pointInOrOnPolygon !p (x:xs) = all (\l -> not (uncurry isRHS l p)) $ zip (x:xs) (xs ++ [x]) - -- | Test whether a point is strictly inside a polygon. -- Supposes the points in the polygon are listed in anticlockwise order. pointInPolygon :: Point2 -> [Point2] -> Bool pointInPolygon !p [] = False pointInPolygon !p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x]) - -- | Debug version of 'pointInPolygon'. errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool errorPointInPolygon !i !p xs @@ -92,36 +80,30 @@ errorPointInPolygon !i !p xs | length xs == 2 = error "two point polygon" | nub xs == xs = pointInPolygon p xs | otherwise = error $ "errorPointInPolygon "++ show i - -- | Debug version of 'normalizeV'. errorNormalizeV :: Int -> Point2 -> Point2 errorNormalizeV !i (0,0) = error $ "problem with function: errorNormalizeV "++show i errorNormalizeV !i !p = normalizeV p - -- | Debug version of 'angleVV'. errorAngleVV :: Int -> Point2 -> Point2 -> Float errorAngleVV !i (0,0) _ = error $ "problem with function: errorAngleVV "++show i errorAngleVV !i _ (0,0) = error $ "problem with function: errorAngleVV "++show i errorAngleVV !i !p !p' = angleVV p p' - -- | Debug version of 'isLHS'. errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool errorIsLHS !i !x !y | x == y = error $ "problem with function: errorIsLHS " ++show i | otherwise = isLHS x y - -- | Debug version of 'closestPointOnLine' errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2 errorClosestPointOnLine !i !x !y | x == y = error $ "problem with function: errorClosestPointOnLine " ++show i | otherwise = closestPointOnLine x y - -- | Debug version of 'closestPointOnLineParam' errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float errorClosestPointOnLineParam !i !x! y! z | x == y = dist x z | otherwise = closestPointOnLineParam x y z - -- | Test whether a point is on the LHS of a line. -- Returns False if the line is of zero length. isLHS @@ -141,7 +123,6 @@ isLHS a2 = y' - y b1 = x'' - x b2 = y'' - y - -- | Test whether a point is on the LHS of a line. -- Returns False if the line is of zero length. isRHS @@ -161,14 +142,12 @@ isRHS a2 = y' - y b1 = x'' - x b2 = y'' - y - -- | Reorder points to be anticlockwise around their center. orderPolygon :: [Point2] -> [Point2] orderPolygon [] = [] orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps where cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps - -- | Adds a point to a convex polygon. -- If the point is inside, returns the original. -- Points ordered anticlockwise, input not checked. @@ -176,21 +155,17 @@ addPointPolygon :: Point2 -> [Point2] -> [Point2] addPointPolygon p ps | pointInOrOnPolygon p ps = ps | otherwise = orderPolygon $ p : ps - -- | Creates the convex hull of a set of points. convexHull :: [Point2] -> [Point2] -convexHull (x:y:z:xs) = foldr addPointPolygon (orderPolygon (x:y:z:[])) xs +convexHull (x:y:z:xs) = foldr addPointPolygon (orderPolygon [x,y,z]) xs convexHull _ = error "Tried to create the convex hull of two or less points" - -- | Return distance between two points. dist :: Point2 -> Point2 -> Float {-# INLINE dist #-} dist !p1 !p2 = magV (p2 -.- p1) - -- | Return midpoint between two points. pHalf :: Point2 -> Point2 -> Point2 pHalf !a !b = 0.5 *.* (a +.+ b) - -- | Test whether a circle is on a segment by intersecting a new normal segment through the -- center of the circle with the segment itself. -- Returns False if the circle center is beyond the enpoints of the @@ -202,40 +177,34 @@ circOnSegNoEndpoints !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2)) isJustTrue (Just True) = True isJustTrue _ = False - -- | Test whether a circle is on a segment by intersecting a normal and testing -- the distance to the endpoints of the segment. circOnSeg :: Point2 -> Point2 -> Point2 -> Float -> Bool {-# INLINE circOnSeg #-} circOnSeg !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad - || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) + || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) where y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2)) isJustTrue (Just True) = True isJustTrue _ = False - -- | Find the difference between two Nums. difference :: (Ord a, Num a) => a -> a -> a difference x y | x > y = x - y | otherwise = y - x - -- | Given vector line direction and a vector movement, -- reflects the movement accoring to the line. reflectIn :: Point2 -> Point2 -> Point2 -reflectIn line vec = - let angle = 2 * angleBetween line vec - in rotateV angle vec - +reflectIn line vec = rotateV angle vec + where + angle = 2 * angleBetween line vec -- | Find angle between two points. -- Not normalised, ranges from -2*pi to 2*pi. angleBetween :: Point2 -> Point2 -> Float angleBetween v1 v2 = argV v1 - argV v2 - -- | Return a list containing two copies of a pair. doublePair :: (a,a) -> [(a,a)] doublePair (x,y) = [(x,y),(y,x)] - -- | Test whether two polygons intersect by testing the intersection of each -- consecutive pair of points. polysIntersect :: [Point2] -> [Point2] -> Bool @@ -245,40 +214,32 @@ polysIntersect (p:ps) (q:qs) pairs1 = zip (p:ps) (ps++[p]) pairs2 = zip (q:qs) (qs++[q]) polysIntersect _ _ = False - -- | Test whether two polygons intersect or if one is contained in the other. polysOverlap :: [Point2] -> [Point2] -> Bool polysOverlap (p:ps) (q:qs) = polysIntersect (p:ps) (q:qs) || pointInPolygon p (q:qs) || pointInPolygon q (p:ps) polysOverlap _ _ = False - -- | Test whether any polygons from a first list intersect with any polygons from -- a second list. anyPolyssIntersect :: [[Point2]] -> [[Point2]] -> Bool anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y - -- | Return n equidistant points on a circle with a radius of 600. nRays :: Int -> [Point2] nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) (600,0) - -- | Return n equidistant points on a circle with a radius of x. nRaysRad :: Int -> Float -> [Point2] nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (x,0) - -- | Test whether an angle is to the left of another angle, according to the -- smallest change in rotation between them. -- This appears to sometimes fail if the angles are not normalized. isLeftOfA :: Float -> Float -> Bool -isLeftOfA angle1 angle2 = - (angle1 - angle2 < pi && angle1 > angle2) +isLeftOfA angle1 angle2 = (angle1 - angle2 < pi && angle1 > angle2) || (angle2 - angle1 > pi && angle2 > angle1) - -- | Test whether a vector is to the left of another, according to the smallest -- change of rotation between them. isLeftOf :: Point2 -> Point2 -> Bool isLeftOf x y = isLeftOfA (argV x) (argV y) - -- | Find the difference between two angles. -- Possibly not correct... diffAngles :: Float -> Float -> Float @@ -292,7 +253,6 @@ diffAngles x y differenceAngles = diffAngles angleDifference = diffAngles - -- | Given a triangle where we know the length of a first side, -- the length of a second side, and the angle between the first side and the -- third side, finds the length of the third side. @@ -305,7 +265,6 @@ ssaTri ab bc a let c = asin ( (ab * sin a)/bc) b = pi - (a + c) in sin b * bc / sin a - -- | Given two points of a triangle and a third point, return -- the point which lies between pa and pc' on a line from pb of length bc. -- Note that there are likely two such points, this should return the point @@ -316,7 +275,6 @@ ssaTriPoint pa pb pc' bc a = errorAngleVV 6 (pb -.- pa) (pc' -.- pa) ac = ssaTri ab bc a in pa +.+ (ac *.* errorNormalizeV 47 (pc' -.- pa)) - -- | Safe version of 'ssaTriPoint'. ssaTriPoint' :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2 ssaTriPoint' pa pb pc' bc @@ -333,41 +291,34 @@ ssaTriPointCorrect pa pb pc' bc where p = ssaTriPoint pa pb pc' bc param = closestPointOnLineParam pa pc' p - -- | Given a segment and external point, find the closest point on the segment. closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2 closestPointOnSeg segP1 segP2 p | errorClosestPointOnLineParam 3 segP1 segP2 p <= 0 = segP1 | errorClosestPointOnLineParam 4 segP1 segP2 p >= 1 = segP2 | otherwise = errorClosestPointOnLine 2 segP1 segP2 p - -- | Return Just a point if it is inside a circle, Nothing otherwise. pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2 pointInCircle p r c | p == c = Just p | magV (p -.- c) < r = Just p | otherwise = Nothing - -- | Determines if a moving point intersects with a circle, -- if so, returns a point on circle that intersects with the line passing -- throught the circle : HOPEFULLY THE CORRECT OF THE TWO! collidePointCirc :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2 collidePointCirc p1 p2 rad c = ssaTriPoint' p2 c p1 rad - -- | As 'collidePointCirc', but changes the point to a measure of the distance. collidePointCirc' :: Point2 -> Point2 -> Float -> Point2 -> Maybe Float collidePointCirc' p1 p2 rad c = fmap (\x -> magV (x -.- p1)) - (collidePointCirc p1 p2 rad c) - + (collidePointCirc p1 p2 rad c) -- | As 'collidePointCirc', but returns both the point and the measure of the distance. collidePointCirc'' :: Point2 -> Point2 -> Float -> Point2 -> Maybe (Point2,Float) collidePointCirc'' p1 p2 rad c = (,) <$> collidePointCirc p1 p2 rad c - <*> collidePointCirc' p1 p2 rad c - + <*> collidePointCirc' p1 p2 rad c -- | As 'collidePointCirc', but uses the supposedly correct version of ssaTriPoint. collidePointCircCorrect :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2 collidePointCircCorrect p1 p2 rad c = ssaTriPointCorrect p2 c p1 rad - -- | Finds the height of a triangle using herons formula. -- The base is the line between the first two points. heron :: Point2 -> Point2 -> Point2 -> Float @@ -380,7 +331,6 @@ heron x y z s = (a+b+c)/2 area = sqrt(s*(s-a)*(s-b)*(s-c)) in 2*area/a - -- | Multiplies reflection in normal by factor. reflectInParam :: Float -> Point2 -> Point2 -> Point2 reflectInParam x line vec = @@ -388,7 +338,6 @@ reflectInParam x line vec = rAng = rotateV angle vec p = x *.* errorClosestPointOnLine 3 (0,0) (vNormal line) rAng in rAng -.- p - --reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 --reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1) @@ -397,47 +346,47 @@ isOnSeg l1 l2 p = errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0 && errorClosestPointOnLineParam 11 l1 l2 p <= 1 && errorClosestPointOnLineParam 12 l1 l2 p >= 0 - -- | Divide a segment into a list of points with a maximal distance between -- them. -- the take 5000 here is a hack, otherwise divideLine seems to sometimes -- generate an infinite list, and I don't know why divideLine :: Float -> Point2 -> Point2 -> [Point2] --divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) -divideLine x a b = - take 5000 +divideLine x a b = take 5000 $ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) ) - ns + ns where d = dist a b numPoints = max 1 $ ceiling $ d / x ns = [0 .. numPoints] - -- | As 'divideLine', but must return an odd number of points. divideLineOddNumPoints :: Float -> Point2 -> Point2 -> [Point2] --divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) divideLineOddNumPoints x a b = take 5000 $ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) ) - ns + ns where d = dist a b numPoints' = max 1 $ ceiling $ d / x - numPoints | even numPoints' = numPoints' - | otherwise = numPoints' + 1 + numPoints + | even numPoints' = numPoints' + | otherwise = numPoints' + 1 ns = [0 .. numPoints] - -- | Given two pairs of Ints, returns a list of pairs of Ints that form -- a digital line between them. digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)] {-# INLINE digitalLine #-} digitalLine (x1,y1) (x2,y2) - | abs (x1-x2) > abs (y1-y2) = [ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) ) - | x <- intervalList x1 x2 ] - | otherwise = [ ( ((x1-x2) * y + y1*x2 - y2*x1) `rdiv` (y1-y2) , y) - | y <- intervalList y1 y2 ] + | abs (x1-x2) > abs (y1-y2) = + [ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) ) + | x <- intervalList x1 x2 + ] + | otherwise = + [ ( ((x1-x2) * y + y1*x2 - y2*x1) `rdiv` (y1-y2) , y) + | y <- intervalList y1 y2 + ] where rdiv a b = round $ fromIntegral a / fromIntegral b - -- | Given two pairs of 'Int's, create a list of pairs of 'Int's that form a -- rectangle between them. digitalRect :: (Int,Int) -> (Int,Int) -> [(Int,Int)] @@ -448,13 +397,11 @@ digitalRect (a,b) (c,d) = [(s,t) | s <- [minx .. maxx] , t <- [miny .. maxy]] minx = min a c maxy = max b d miny = min b d - -- | Given two Ints, creates the list of Ints between these. intervalList :: Int -> Int -> [Int] intervalList x y | y >= x = [x .. y] | otherwise = reverse [y..x] - -- | Create points on the circumference of a circle with maximal distance -- between them. divideCircle :: Float -> Point2 -> Float -> [Point2] @@ -478,7 +425,7 @@ arcStepwisePositive -> Point2 -- ^ Center -> Point2 -- ^ Start vector from center -> [Point2] -arcStepwisePositive ssize a cen v = ((cen +.+) . (\rot -> rotateV rot v) ) <$> rots +arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots where rots :: [Float] rots = map ((a*) . (/ fromIntegral n ) . fromIntegral) [0 .. n] @@ -502,7 +449,6 @@ makeLoopPairs :: [Point2] -> [(Point2,Point2)] makeLoopPairs [] = error "tried to make loop with empty list of points" makeLoopPairs [x] = error "tried to make loop with singleton list of points" makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x]) - -- | Test whether a point is in a cone. -- Note the pair is ordered. -- Doesn't work for obtuse angles. @@ -512,4 +458,6 @@ pointIsInCone -> Point2 -- ^ Point to test. -> Bool pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p - +-- | TODO: implement using Control.Foldl +centroid :: Foldable t => t Point2 -> Point2 +centroid xs = 1 / fromIntegral (length xs) *.* foldl' (+.+) (0,0) xs diff --git a/src/Loop.hs b/src/Loop.hs index 3c5dcd519..5b67dfc2d 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -1,6 +1,6 @@ {- | Module : Loop -Description : Minimal game loop +Description : Simple game loop This module sets up an SDL window which may be updated using a simple game loop. -} @@ -41,7 +41,7 @@ setupLoop startWorld <- ioStartWorld initializeAll bracket - (createWindow (T.pack "A Minimal Game Loop") (winConfig xSize ySize)) + (createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize)) destroyWindow $ \window -> bracket (glCreateContext window) diff --git a/src/Music.hs b/src/Music.hs index ad5d4e3e0..55c3610d9 100644 --- a/src/Music.hs +++ b/src/Music.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} module Music where import qualified SDL.Mixer as Mix diff --git a/src/Picture.hs b/src/Picture.hs index dc478a00a..e011dc369 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -120,7 +120,7 @@ extrapolate (ox,oy) (ax,ay) (bx,by) (x,y) = color :: RGBA -> Picture -> Picture {-# INLINE color #-} -color c pic = OverPic id id 0 (const c) pic +color c = OverPic id id 0 (const c) translate3 :: Float -> Float -> Point3 -> Point3 {-# INLINE translate3 #-} @@ -128,15 +128,15 @@ translate3 a b (x,y,z) = (x+a,y+b,z) translate :: Float -> Float -> Picture -> Picture {-# INLINE translate #-} -translate x y pic = OverPic (translate3 x y) id 0 id pic +translate x y = OverPic (translate3 x y) id 0 id setDepth :: Float -> Picture -> Picture {-# INLINE setDepth #-} -setDepth d pic = OverPic (\(x,y,_) -> (x,y,d)) id 0 id pic +setDepth d = OverPic (\(x,y,_) -> (x,y,d)) id 0 id setLayer :: Int -> Picture -> Picture {-# INLINE setLayer #-} -setLayer i pic = OnLayer i pic +setLayer = OnLayer scale3 :: Float -> Float -> Point3 -> Point3 {-# INLINE scale3 #-} @@ -144,7 +144,7 @@ scale3 a b (x,y,z) = (x*a,y*b,z) scale :: Float -> Float -> Picture -> Picture {-# INLINE scale #-} -scale x y pic = OverPic (scale3 x y) (\(a,b) ->(a*x,b*y)) 0 id pic +scale x y = OverPic (scale3 x y) (\(a,b) ->(a*x,b*y)) 0 id rotate3 :: Float -> Point3 -> Point3 {-# INLINE rotate3 #-} @@ -154,7 +154,7 @@ rotate3 a (x,y,z) = (x',y',z) rotate :: Float -> Picture -> Picture {-# INLINE rotate #-} -rotate a pic = OverPic (rotate3 a) id a id pic +rotate a = OverPic (rotate3 a) id a id pictures :: [Picture] -> Picture {-# INLINE pictures #-} @@ -162,9 +162,9 @@ pictures = Pictures makeArc :: Float -> (Float,Float) -> [Point2] {-# INLINE makeArc #-} -makeArc rad (a,b) = zipWith rotateV as (repeat (0,rad)) +makeArc rad (a,b) = map (`rotateV` (0,rad)) angles where - as = [a,a+step.. b] + angles = [a,a+step.. b] step = pi * 0.2 circleSolid :: Float -> Picture @@ -203,7 +203,7 @@ thickLine ps t = pictures $ f ps thickCircle :: Float -> Float -> Picture {-# INLINE thickCircle #-} -thickCircle rad wdth = thickArc 0 (2*pi) rad wdth +thickCircle = thickArc 0 (2*pi) arcSolid :: Float -> Float -> Float -> Picture {-# INLINE arcSolid #-} diff --git a/src/SameConstr.hs b/src/SameConstr.hs index f4c6c0650..832537cc3 100644 --- a/src/SameConstr.hs +++ b/src/SameConstr.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DefaultSignatures, TypeOperators, FlexibleContexts #-} +{-# LANGUAGE TypeOperators, FlexibleContexts #-} {- | Pulled from https://stackoverflow.com/questions/10112733/haskell-simple-constructor-comparison-function -} diff --git a/src/Shader.hs b/src/Shader.hs index 38bdeaffc..8c8b321c2 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} module Shader ( makeShader , addTexture @@ -47,7 +46,7 @@ extractProgAndUnis :: FullShader a -> (Program,[UniformLocation]) extractProgAndUnis s = (_shaderProgram s, _shaderUniforms s) pokeShaders :: [FullShader a] -> F.FoldM IO a [Int] -pokeShaders fss = traverse pokeShader fss +pokeShaders = traverse pokeShader pokeShader :: FullShader a -> F.FoldM IO a Int pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return @@ -61,18 +60,17 @@ pokeRender :: (a -> [[[Float]]]) pokeRender toFs ptrs n rt = pokeList ptrs n (toFs rt) pokeList :: [(Ptr Float,Int)] -> Int -> [[[Float]]] -> IO Int -pokeList ptrs n fsss = foldM (pokePtrs ptrs) n fsss +pokeList ptrs = foldM (pokePtrs ptrs) pokePtrs :: [(Ptr Float,Int)] -> Int -> [[Float]] -> IO Int pokePtrs ptrIs n fss = do zipWithM_ f ptrIs fss return $ n + 1 - where f (ptr,i) fs = pokeArrayOff ptr (i*n) fs + where + f (ptr,i) fs = pokeArrayOff ptr (i*n) fs pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO () -pokeArrayOff ptr i xs = - zipWithM_ (pokeElemOff ptr) [i..] xs - +pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..] bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO () {-# INLINE bindArrayBuffers #-} @@ -82,22 +80,20 @@ bindArrayBuffers numVs ps = do bufferData ArrayBuffer $= (fromIntegral $ floatSize * numVs * i, ptr, StreamDraw) bindShaderBuffers :: [FullShader a] -> [Int] -> IO () -bindShaderBuffers fss is = - zipWithM_ f fss is +bindShaderBuffers = zipWithM_ f where f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs drawShaders :: [FullShader a] -> [Int] -> IO () -drawShaders fss is = - zipWithM_ drawShader fss is +drawShaders = zipWithM_ drawShader drawShader :: FullShader a -> Int -> IO () {-# INLINE drawShader #-} drawShader fs i = do currentProgram $= Just (_shaderProgram fs) - bindVertexArrayObject $= (Just (_vao $ _shaderVAO fs)) + bindVertexArrayObject $= Just (_vao $ _shaderVAO fs) case _shaderTexture fs of - Just (ShaderTexture {_textureObject = to}) + Just ShaderTexture{_textureObject = to} -> textureBinding Texture2D $= Just to _ -> return () drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i) diff --git a/src/Sound.hs b/src/Sound.hs index fdadf5886..a690ea2c3 100644 --- a/src/Sound.hs +++ b/src/Sound.hs @@ -50,10 +50,7 @@ In the update: -} playAndUpdate :: Ord a => SoundData a -> M.Map a Sound -> IO (M.Map a Sound) playAndUpdate sData newSounds - = updateSounds (_loadedChunks sData) (mergeSounds newSounds (_playingSounds sData)) - -mergeSounds :: Ord a => M.Map a Sound -> M.Map a Sound -> M.Map a Sound -mergeSounds as bs = M.unionWith mergeSound as bs + = updateSounds (_loadedChunks sData) (M.unionWith mergeSound newSounds (_playingSounds sData)) mergeSound :: Sound -> Sound -> Sound mergeSound newS oldS @@ -85,7 +82,7 @@ tryPlay sd s = do Mix.halt i Mix.playOn i Mix.Once (sd IM.! _soundChunkID s) return $ s - & soundChannel .~ Just i + & soundChannel ?~ i & soundStatus .~ Playing repetitions :: Sound -> Mix.Times @@ -100,14 +97,13 @@ tryGetChannel s = case _soundChannel s of decrementTimer :: Sound -> IO Sound decrementTimer s = case _soundTime s of - Just t | t > 0 -> return $ s & soundTime .~ Just (t - 1) - | otherwise -> fadeOutMaybe (_soundChannel s) (_soundFadeTime s) + Just t + | t > 0 -> return $ s & soundTime ?~ t - 1 + | otherwise -> fadeOutMaybe (_soundChannel s) (_soundFadeTime s) >> return (s & soundTime .~ Nothing & soundStatus .~ FadingOut) Nothing -> return s ---applyPosition = return - applyPosition :: Sound -> IO Sound applyPosition s = case _soundPos s of Nothing -> return s diff --git a/test/Spec.hs b/test/Spec.hs index 2eddecebe..4b0bb4237 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -30,11 +30,11 @@ polygonStrictlyConvex ps = True --prop_looping :: [Point2] -> [WallP] -> Bool prop_looping = forAllShrink genTris shrinkTris $ \tris -> - (all (not . (\[a,b,c] -> isOnSeg a b c + not (any ( \[a,b,c] -> isOnSeg a b c || isOnSeg a c b || isOnSeg b c a - ) ) tris) - ==> (isLooping' $ foldr cutWalls' [] tris) + ) tris) + ==> isLooping' (foldr cutWalls' [] tris) shrinkTris [] = [] shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs)