Refactor
This commit is contained in:
@@ -46,6 +46,7 @@ dependencies:
|
||||
- aeson
|
||||
- directory
|
||||
- QuickCheck
|
||||
- extra
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
|
||||
+193
-351
@@ -4,6 +4,7 @@ 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
|
||||
@@ -14,7 +15,7 @@ import Data.List
|
||||
import Data.Char
|
||||
import Data.Maybe
|
||||
import Data.Function
|
||||
import Data.Graph.Inductive.Graph
|
||||
import Data.Graph.Inductive.Graph hiding ((&))
|
||||
import Data.Graph.Inductive.PatriciaTree
|
||||
import Data.Graph.Inductive.Query.SP
|
||||
import qualified Data.ByteString as B
|
||||
@@ -29,6 +30,158 @@ import Control.Concurrent
|
||||
import System.Random
|
||||
import Foreign.ForeignPtr
|
||||
|
||||
expandToAI
|
||||
:: ( World -> StdGen -> Creature -> (World -> World, StdGen, Creature) )
|
||||
-> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
|
||||
expandToAI ai w (f,g) cr =
|
||||
let (sideE, g', cr') = ai w g cr
|
||||
in ((sideE . f, g'), Just cr')
|
||||
|
||||
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 ypos ypos ) : dams )
|
||||
ypos = _crPos $ you w
|
||||
combinedRad = _crRad cr + _crRad (you w)
|
||||
(a,g) = randomR (-0.2,0.2) g'
|
||||
(wtime,g1) = randomR (15,25) g'
|
||||
randomTurn = over crDir (+a)
|
||||
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
|
||||
replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs)
|
||||
addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ 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') , replaceGoal [] cr)
|
||||
(Wait:_) | dist cpos ypos < 900 && hasLOS cpos ypos w
|
||||
-> ((f ,g')
|
||||
,addGoal [[WaitFor wtime,MoveTo ypos]] cr)
|
||||
| dist cpos ypos < 900 && hasLOSIndirect cpos ypos w
|
||||
-> ((f , g')
|
||||
,addGoal [[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 pointTowardsGoal cpos p w of
|
||||
Just q -> ( (f , g)
|
||||
|
||||
, addAction [MoveToFor q 10] cr
|
||||
)
|
||||
_ -> ((f , g)
|
||||
|
||||
, replaceAction [] cr
|
||||
)
|
||||
|
||||
-- case pointTowardsGoal' 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 )
|
||||
|
||||
|
||||
factionIs :: Faction -> Creature -> Bool
|
||||
factionIs f c = (_faction $ _crState $ c) == f
|
||||
|
||||
@@ -220,149 +373,6 @@ placeCrFaction cr fact p op rot w = over creatures addCr w
|
||||
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 ypos ypos ) : dams )
|
||||
ypos = _crPos $ you w
|
||||
combinedRad = _crRad cr + _crRad (you w)
|
||||
(a,g) = randomR (-0.2,0.2) g'
|
||||
(wtime,g1) = randomR (15,25) g'
|
||||
randomTurn = over crDir (+a)
|
||||
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
|
||||
replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs)
|
||||
addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ 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') , replaceGoal [] cr)
|
||||
(Wait:_) | dist cpos ypos < 900 && hasLOS cpos ypos w
|
||||
-> ((f ,g')
|
||||
,addGoal [[WaitFor wtime,MoveTo ypos]] cr)
|
||||
| dist cpos ypos < 900 && hasLOSIndirect cpos ypos w
|
||||
-> ((f , g')
|
||||
,addGoal [[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 pointTowardsGoal cpos p w of
|
||||
Just q -> ( (f , g)
|
||||
|
||||
, addAction [MoveToFor q 10] cr
|
||||
)
|
||||
_ -> ((f , g)
|
||||
|
||||
, replaceAction [] cr
|
||||
)
|
||||
|
||||
-- case pointTowardsGoal' 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
|
||||
@@ -1610,6 +1620,7 @@ basicShooterAI w (f,g) cr =
|
||||
-> ( (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
|
||||
@@ -1618,75 +1629,51 @@ sniperAI w (f,g) cr =
|
||||
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
|
||||
turnCloseSlow p
|
||||
| errorAngleVV 22 (p -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4
|
||||
= crTurnTowardSpeed 0.01 p
|
||||
| otherwise = crTurnTowardSpeed 0.05 p
|
||||
| otherwise = crTurnTowardSpeed 0.05 p
|
||||
replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs)
|
||||
addGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ 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 = replaceGoal [[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 )
|
||||
, replaceGoal [[AimAt ypos aimtime]] cr
|
||||
)
|
||||
| otherwise -> ( ( f , g )
|
||||
, replaceGoal [] cr
|
||||
)
|
||||
(WaitFor x:gls)| canSeeFire cpos ypos w -> ( ( f , g1 )
|
||||
, replaceGoal [[AimAt ypos aimtime]] cr
|
||||
)
|
||||
| x == 0 -> ( (f ,g ), replaceAction [] cr )
|
||||
| otherwise -> ( (f ,g ), replaceAction [WaitFor (x-1)] cr )
|
||||
in case head $ _goals $ _crState cr of
|
||||
[] | canSeeFire cpos ypos w -> ( ( f , g1 ) , replaceGoal [[AimAt ypos aimtime]] cr)
|
||||
| otherwise -> ( ( f , g ) , replaceGoal [] cr)
|
||||
(WaitFor x:gls)
|
||||
| canSeeFire cpos ypos w -> ( ( f , g1 ) , replaceGoal [[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)
|
||||
, replaceGoal [[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 pointTowardsGoal 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 )
|
||||
, replaceGoal [[Reload
|
||||
,WaitFor 50
|
||||
--,Search 1 ,WaitFor 100
|
||||
]]
|
||||
cr
|
||||
)
|
||||
| canSeeFireVisionAll cid (_yourID w) w
|
||||
-> ( (tryUseItem cid . f , g)
|
||||
, replaceGoal [[FireAt ypos]] $ turnCloseSlow p cr
|
||||
)
|
||||
| pathToPointFireable cid p w
|
||||
-> ( (tryUseItem cid . f , g)
|
||||
, Just $ turnCloseSlow p cr
|
||||
)
|
||||
| otherwise -> ( (f , g)
|
||||
, replaceGoal [[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)
|
||||
| canSeeFire cpos ypos w -> ( (f , g1) , replaceGoal [[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 pointTowardsGoal 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 ) , replaceGoal [[Reload ,WaitFor 50 ]] cr)
|
||||
| canSeeFireVisionAll cid (_yourID w) w ->
|
||||
( (tryUseItem cid . f , g) , replaceGoal [[FireAt ypos]] $ turnCloseSlow p cr)
|
||||
| pathToPointFireable cid p w ->
|
||||
( (tryUseItem cid . f , g) , Just $ turnCloseSlow p cr)
|
||||
| otherwise ->
|
||||
( (f , g) , replaceGoal [[WaitFor 50 ]] cr)
|
||||
(Reload:gls)
|
||||
| _wpReloadState wp == 0 -> ( (f , g) , replaceAction [] cr )
|
||||
| canSeeFireVisionAny cid (_yourID w) w ->
|
||||
( (f , g) , Just $ turnCloseSlow ypos cr)
|
||||
| otherwise -> ( (f , g) , Just cr)
|
||||
(Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr)
|
||||
| otherwise
|
||||
-> ( ( f , g1)
|
||||
@@ -1712,155 +1699,10 @@ sniperAI w (f,g) cr =
|
||||
-> ( (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
|
||||
-- replaceGoal newGoals = over (creatures . ix cid . crState . goals)
|
||||
-- (\gs -> newGoals ++ tail gs)
|
||||
-- addGoal newGoals = over (creatures . ix cid . crState . goals)
|
||||
-- (\gs -> newGoals ++ 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 = replaceGoal [[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
|
||||
-- -> replaceGoal [[AimAt ypos 50]] w
|
||||
-- | otherwise -> replaceGoal [] w
|
||||
-- (WaitFor x:gls)| canSeeAny cid (_yourID w) w
|
||||
-- -> replaceGoal [[AimAt ypos 50]] w
|
||||
-- | x == 0 -> replaceAction [] w
|
||||
-- | otherwise -> replaceAction [WaitFor (x-1)] w
|
||||
-- (MoveToFor p x:gls)
|
||||
-- | canSeeAny cid (_yourID w) w -> replaceGoal [[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 pointTowardsGoal cpos p w of
|
||||
-- Just q -> addAction [MoveToFor q 100] w
|
||||
-- _ -> replaceAction [] w
|
||||
-- (MoveFire mp tp:gls)
|
||||
-- | noAmmo -> replaceGoal [[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
|
||||
-- -> addGoal [[AimAt ypos 50]] w
|
||||
-- | dist cpos p > 10
|
||||
-- -> addGoal [[PathTo p]] w
|
||||
-- | errorAngleVV 21 (unitVectorAtAngle (_crDir cr)) (p' -.- p) > pi/8
|
||||
-- -> turnTowardSpeed 0.05 p' cid w
|
||||
-- | otherwise -> w
|
||||
-- (InitGuard :_) -> replaceGoal [[Guard cpos (cpos +.+ 50 *.* unitVectorAtAngle (_crDir cr))]] w
|
||||
-- (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
|
||||
-- -> replaceGoal [[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 (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
|
||||
|
||||
|
||||
----------------
|
||||
|
||||
sigmoid x = x/sqrt(1+x^2)
|
||||
|
||||
@@ -225,10 +225,12 @@ Items you start with.
|
||||
startInventory = IM.fromList (zip [0..20]
|
||||
(
|
||||
[bezierGun
|
||||
,autoGun
|
||||
,hvAutoGun
|
||||
,remoteLauncher
|
||||
,grenade
|
||||
,spawnGun lamp
|
||||
,lasGun
|
||||
,autoGun
|
||||
--,poisonSprayer
|
||||
--,launcher
|
||||
--,lasGun
|
||||
|
||||
@@ -3,11 +3,12 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module Dodge.Creature.Action
|
||||
( module Dodge.Creature.Action
|
||||
, useItem
|
||||
, tryUseItem
|
||||
, module Dodge.Creature.Action.UseItem
|
||||
, module Dodge.Creature.Action.Movement
|
||||
)
|
||||
where
|
||||
import Dodge.Creature.Action.UseItem
|
||||
import Dodge.Creature.Action.Movement
|
||||
import Dodge.WorldEvent.Shockwave
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
@@ -87,12 +88,6 @@ stepForward speed cr = over (crState . stance . carriage) f cr
|
||||
f (w@Walking {}) = w {_stepToAdd = ceiling speed}
|
||||
f s = s
|
||||
|
||||
{- Determine the speed modifier of an item. -}
|
||||
equipSpeed :: Item -> Float
|
||||
equipSpeed NoItem = 1
|
||||
equipSpeed it | _itIdentity it == FrontArmour = 0.75
|
||||
| _itIdentity it == FlameShield = 0.75
|
||||
| otherwise = 1
|
||||
|
||||
turnTo
|
||||
:: Point2 -- ^ Target point
|
||||
|
||||
@@ -0,0 +1,22 @@
|
||||
module Dodge.Creature.Action.Movement
|
||||
where
|
||||
import Dodge.Data
|
||||
import Geometry
|
||||
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
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)
|
||||
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid
|
||||
cr = _creatures w IM.! cid
|
||||
wpFactor = _itAimingSpeed (_crInv cr IM.! _crInvSel cr)
|
||||
|
||||
{- Determine the speed modifier of an item. -}
|
||||
equipSpeed :: Item -> Float
|
||||
equipSpeed NoItem = 1
|
||||
equipSpeed it | _itIdentity it == FrontArmour = 0.75
|
||||
| _itIdentity it == FlameShield = 0.75
|
||||
| otherwise = 1
|
||||
@@ -12,7 +12,10 @@ import Data.Maybe (fromMaybe)
|
||||
useItem :: Int -> World -> World
|
||||
useItem n w = equippedItemEffect n w
|
||||
|
||||
tryUseItem :: Int -> World -> World
|
||||
tryUseItem
|
||||
:: Int -- ^ Creature id
|
||||
-> World
|
||||
-> World
|
||||
tryUseItem cid w = case w ^? creatures . ix cid of
|
||||
Just cr -> itemEffect cid (_crInv cr IM.! _crInvSel cr) w
|
||||
Nothing -> w
|
||||
@@ -20,11 +23,15 @@ tryUseItem cid w = case w ^? creatures . ix cid of
|
||||
equippedItemEffect :: Int -> World -> World
|
||||
equippedItemEffect n w = itemEffect n it w
|
||||
where
|
||||
c = (_creatures w IM.! n)
|
||||
c = _creatures w IM.! n
|
||||
it = _crInv c IM.! _crInvSel c
|
||||
|
||||
itemEffect :: Int -> Item -> World -> World
|
||||
itemEffect n (Consumable {_cnEffect=eff }) w = fromMaybe w $ fmap (rmSelectedInvItem n) $ eff n w
|
||||
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 _ _ w = w
|
||||
|
||||
@@ -1,7 +1,6 @@
|
||||
module Dodge.Creature.Property
|
||||
where
|
||||
import Dodge.Data
|
||||
|
||||
import Geometry
|
||||
|
||||
import Control.Lens
|
||||
|
||||
@@ -86,6 +86,7 @@ data Carriage
|
||||
= Walking { _stepCycle :: Int, _stepToAdd :: Int }
|
||||
| Standing
|
||||
| Floating
|
||||
| Flying
|
||||
| Boosting Point2
|
||||
deriving (Eq,Show)
|
||||
data Posture = Aiming | AtEase
|
||||
|
||||
@@ -21,7 +21,7 @@ yourControl w (f,g) cr = ( (updateUsingInput . f, g)
|
||||
, Just . crAutoReload . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr
|
||||
)
|
||||
where
|
||||
strafeSpeed = _varMovementSpeedModifier w * equipFactor * (fromMaybe 1 $ yourItem w ^? itAimingSpeed)
|
||||
strafeSpeed = _varMovementSpeedModifier w * equipFactor * fromMaybe 1 (yourItem w ^? itAimingSpeed)
|
||||
speed = _varMovementSpeedModifier w * equipFactor
|
||||
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! 0
|
||||
|
||||
@@ -37,16 +37,16 @@ wasdWithAiming w speed aimSpeed i cr
|
||||
. set crDir mouseDir
|
||||
$ set (crState . stance . carriage) (Boosting mov)
|
||||
cr
|
||||
| (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isMoving && isAiming
|
||||
| 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
|
||||
| any (\it -> it ^? itIdentity == Just JetPack) (_crInv cr) && isMoving
|
||||
= over crPos (+.+ (speed *.* mov))
|
||||
. over crDir (flip fromMaybe dir)
|
||||
$ set (crState . stance . carriage) (Boosting mov)
|
||||
cr
|
||||
| (any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr) && isAiming
|
||||
| any (\it -> it ^? itIdentity == Just JetPack) (_crInv cr) && isAiming
|
||||
= set (crState . stance . carriage) Floating
|
||||
$ set crDir mouseDir
|
||||
cr
|
||||
@@ -61,25 +61,25 @@ wasdWithAiming w speed aimSpeed i cr
|
||||
cr
|
||||
| isMoving
|
||||
= stepForward speed
|
||||
$ over ( crPos) (+.+ (speed *.* mov))
|
||||
$ over ( crDir) (flip fromMaybe dir)
|
||||
$ over crPos (+.+ (speed *.* mov))
|
||||
$ over crDir (`fromMaybe` dir)
|
||||
$ set (crState . stance . carriage) (Walking 0 0)
|
||||
cr
|
||||
| otherwise
|
||||
= over ( crDir) (flip fromMaybe dir)
|
||||
= over crDir (`fromMaybe` dir)
|
||||
$ set (crState . stance . carriage) Standing
|
||||
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
|
||||
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
|
||||
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
|
||||
|
||||
@@ -59,7 +59,7 @@ handlePressedKeyInGame _ w = Just w
|
||||
handlePressedKey :: Bool -> Scancode -> World -> Maybe World
|
||||
handlePressedKey True _ w = Just w
|
||||
handlePressedKey _ scode w
|
||||
| _menuLayers w == []
|
||||
| null (_menuLayers w)
|
||||
= handlePressedKeyInGame scode w
|
||||
| otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w
|
||||
handlePressedKey _ _ w = Just w
|
||||
|
||||
@@ -48,6 +48,10 @@ roomTreex = do
|
||||
t = treeFromTrunk
|
||||
[[StartRoom]
|
||||
,[Corridor]
|
||||
,[Corridor]
|
||||
,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 200]
|
||||
,[Corridor]
|
||||
,[Corridor]
|
||||
,[SpecificRoom . fmap (pure . Right) $ twinSlowDoorChasers 30]
|
||||
,[Corridor]
|
||||
,[DoorAno]
|
||||
|
||||
@@ -30,5 +30,5 @@ 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) ((\x-> min x 10000). (+ hp) ) w
|
||||
$ over (creatures . ix n . crHP) ((min 10000) . (+ hp) ) w
|
||||
|
||||
|
||||
+17
-13
@@ -136,8 +136,7 @@ autoGun = defaultGun
|
||||
autoFireMode = shootWithSound (fromIntegral autoGunSound)
|
||||
. torqueBefore 0.05
|
||||
$ autoGunNonTwistEff
|
||||
singleFireMode = hammerCheck $ shootWithSound (fromIntegral autoGunSound)
|
||||
$ autoGunNonTwistEff
|
||||
singleFireMode = hammerCheck $ shootWithSound (fromIntegral autoGunSound) autoGunNonTwistEff
|
||||
autoGunNonTwistEff = withRecoil 40
|
||||
. withRandomDir (autogunSpread/2)
|
||||
. withMuzFlare
|
||||
@@ -612,12 +611,12 @@ aTeslaArc cid w = aTeslaArc' cid
|
||||
$ soundFrom (CrWeaponSound cid) 25 1 0 w
|
||||
|
||||
aTeslaArc' :: Int -> World -> World
|
||||
aTeslaArc' cid w =
|
||||
teslaGunFlashAt (pos +.+ 5 *.* unitVectorAtAngle dir)
|
||||
$ over projectiles (IM.insert i (makeTeslaArcAt i pos dir))
|
||||
$ set randGen g w
|
||||
aTeslaArc' cid w
|
||||
= teslaGunFlashAt (pos +.+ 5 *.* unitVectorAtAngle dir)
|
||||
$ over projectiles (IM.insert i (makeTeslaArcAt i pos dir))
|
||||
$ set randGen g w
|
||||
where
|
||||
cr = (_creatures w IM.! cid)
|
||||
cr = _creatures w IM.! cid
|
||||
i = newProjectileKey w
|
||||
pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir)
|
||||
+.+ sideOffset *.* vNormal (unitVectorAtAngle dir)
|
||||
@@ -1019,13 +1018,18 @@ moveRemoteShell time i cid itid dir w
|
||||
. _Just . scopePos .~ (newPos -.- _crPos (_creatures w' IM.! cid))
|
||||
_ -> w'
|
||||
|
||||
explodeRemoteRocket :: Int -> Int -> Int -> World -> World
|
||||
explodeRemoteRocket
|
||||
:: Int -- ^ Item id
|
||||
-> Int -- ^ Projectile id
|
||||
-> Int
|
||||
-> World
|
||||
-> World
|
||||
explodeRemoteRocket itid pjid n w
|
||||
= set (projectiles . ix pjid . pjUpdate) (retireRemoteRocket itid 30 pjid)
|
||||
$ set (projectiles . ix pjid . pjPict) blank
|
||||
$ set (itPoint . wpFire) (flip const)
|
||||
$ resetName
|
||||
$ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w
|
||||
$ set (projectiles . ix pjid . pjPict) blank
|
||||
$ set (itPoint . wpFire) (const id)
|
||||
$ resetName
|
||||
$ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w
|
||||
where
|
||||
resetName = set (itPoint . itName) "REMOTELAUNCHER"
|
||||
itPoint = pointToItem $ _itemPositions w IM.! itid
|
||||
@@ -1073,7 +1077,7 @@ explodeRemoteBomb :: Int -> Int -> Int -> World -> World
|
||||
explodeRemoteBomb itid pjid n w
|
||||
= set (projectiles . ix pjid . pjUpdate) (retireRemoteBomb itid 30 pjid)
|
||||
$ set (projectiles . ix pjid . pjPict) blank
|
||||
$ set (creatures . ix n . crInv . ix j . twFire) (flip const)
|
||||
$ set (creatures . ix n . crInv . ix j . twFire) (const id)
|
||||
$ resetName
|
||||
$ resetPict
|
||||
-- $ resetScope
|
||||
|
||||
@@ -17,7 +17,6 @@ import System.Random
|
||||
import Control.Lens
|
||||
import Control.Monad.State
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
|
||||
-- | Basic bullet hit creature effect.
|
||||
bulHitCr' :: Particle -> Point2 -> Creature -> World -> World
|
||||
bulHitCr' bt p cr w
|
||||
@@ -38,10 +37,7 @@ bulHitCr' bt p cr w
|
||||
(d1,g) = randomR (-0.7,0.7) $ _randGen w
|
||||
(colID,_) = randomR (0,11) $ _randGen w
|
||||
p1 = p +.+ 2 *.* safeNormalizeV (p -.- _crPos cr)
|
||||
|
||||
{- |
|
||||
Bounce off armoured creatures, otherwise do damage.
|
||||
-}
|
||||
{- | Bounce off armoured creatures, otherwise do damage. -}
|
||||
bulBounceArmCr' :: Particle -> Point2 -> Creature -> World -> World
|
||||
bulBounceArmCr' bt p cr w
|
||||
| crIsArmouredFrom p cr
|
||||
@@ -65,10 +61,7 @@ bulBounceArmCr' bt p cr w
|
||||
bouncer = (aGenBulAt' Nothing (_btColor' bt) pOut reflectVel
|
||||
(_btHitEffect' bt) (_btWidth' bt)
|
||||
) {_btTimer' = _btTimer' bt - 1}
|
||||
|
||||
{- |
|
||||
Bullet pass through creatures.
|
||||
-}
|
||||
{- | Bullet pass through creatures. -}
|
||||
bulPenCr' :: Particle -> Point2 -> Creature -> World -> World
|
||||
bulPenCr' bt p cr w
|
||||
= over (creatures . ix cid . crState . crDamage)
|
||||
@@ -91,8 +84,7 @@ bulPenCr' bt p cr w
|
||||
piercer = (aGenBulAt' (Just cid) (_btColor' bt) p (_btVel' bt)
|
||||
(_btHitEffect' bt) (_btWidth' bt)
|
||||
) {_btTimer' = _btTimer' bt - 1}
|
||||
{- |
|
||||
Heavy bullet effects when hitting creature:
|
||||
{- | Heavy bullet effects when hitting creature:
|
||||
piercing, blunt, twisting and pushback damage all applied. -}
|
||||
hvBulHitCr' :: Particle -> Point2 -> Creature -> World -> World
|
||||
hvBulHitCr' bt p cr w
|
||||
@@ -111,8 +103,7 @@ hvBulHitCr' bt p cr w
|
||||
cid = _crID cr
|
||||
sp = head $ _btTrail' bt
|
||||
ep = sp +.+ _btVel' bt
|
||||
{- |
|
||||
Create a flamelet when hitting a creature. -}
|
||||
{- | Create a flamelet when hitting a creature. -}
|
||||
bulIncCr' :: Particle -> Point2 -> Creature -> World -> World
|
||||
bulIncCr' bt p cr w
|
||||
= over (creatures . ix cid . crState . crDamage)
|
||||
@@ -126,8 +117,7 @@ bulIncCr' bt p cr w
|
||||
ep = sp +.+ _btVel' bt
|
||||
v = evalState (randInCirc 1) $ _randGen w
|
||||
incFlamelets = over worldEvents $ (.) (makeFlameletTimed p v Nothing 3 20)
|
||||
{- |
|
||||
Creates a shockwave when hitting a creature. -}
|
||||
{- | Creates a shockwave when hitting a creature. -}
|
||||
bulConCr' :: Particle -> Point2 -> Creature -> World -> World
|
||||
bulConCr' bt p cr w
|
||||
= over (creatures . ix cid . crState . crDamage)
|
||||
@@ -140,8 +130,7 @@ bulConCr' bt p cr w
|
||||
sp = head $ _btTrail' bt
|
||||
ep = sp +.+ _btVel' bt
|
||||
mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
|
||||
{- |
|
||||
Hitting wall effects: create a spark, damage blocks. -}
|
||||
{- | Hitting wall effects: create a spark, damage blocks. -}
|
||||
bulHitWall' :: Particle -> Point2 -> Wall -> World -> World
|
||||
bulHitWall' bt p x w = damageBlocks x
|
||||
$ createSpark 8 colID pOut (reflectDir x) Nothing
|
||||
@@ -153,14 +142,11 @@ bulHitWall' bt p x w = damageBlocks x
|
||||
(colID,g) = randomR (0,11) $ _randGen w
|
||||
(a, _) = randomR (-0.1,0.1) $ _randGen w
|
||||
spid = newKey $ _projectiles w
|
||||
reflectDir wall = a +
|
||||
argV (reflectIn ((snd $ _wlLine wall) -.- (fst $ _wlLine wall)) (p -.- sp) )
|
||||
reflectDir wall = a + argV (reflectIn (uncurry (-.-) (_wlLine wall)) (p -.- sp) )
|
||||
damageBlocks wall w = case wall ^? blHP of
|
||||
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
|
||||
Just hp -> foldr (\j -> (walls . ix j . blHP -~ 5)) w (_blIDs wall)
|
||||
_ -> w
|
||||
{- |
|
||||
Bounce off walls, do damage to blocks.
|
||||
-}
|
||||
{- | Bounce off walls, do damage to blocks. -}
|
||||
bulBounceWall' :: Particle -> Point2 -> Wall -> World -> World
|
||||
bulBounceWall' bt p wl w = damageBlocks wl $ over worldEvents addBouncer w
|
||||
where
|
||||
@@ -168,20 +154,19 @@ 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 -> over (walls . ix j . blHP) (\y -> y - 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)
|
||||
) {_btTimer' = _btTimer' bt - 1}
|
||||
wallV = (snd $ _wlLine wl) -.- (fst $ _wlLine wl)
|
||||
reflectVel = (reflectIn wallV (_btVel' bt))
|
||||
addBouncer = (.) ( over particles (bouncer : ) )
|
||||
wallV = uncurry (-.-) (_wlLine wl)
|
||||
reflectVel = reflectIn wallV (_btVel' bt)
|
||||
addBouncer = ( over particles (bouncer : ) . )
|
||||
-- the hack is to get around the fact that the particles list gets reset after
|
||||
-- all projectiles in it are checked, so we cannot add to it as we accumulate over
|
||||
-- this list
|
||||
|
||||
{- | Create flamelet on wall.
|
||||
-}
|
||||
{- | Create flamelet on wall. -}
|
||||
bulIncWall'
|
||||
:: Particle
|
||||
-> Point2 -- Impact point
|
||||
@@ -194,16 +179,15 @@ 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 -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
|
||||
Just hp -> foldr (\j -> (walls . ix j . blHP -~ 5)) w (_blIDs wall)
|
||||
_ -> w
|
||||
wallV = (snd $ _wlLine wl) -.- (fst $ _wlLine wl)
|
||||
wallV = uncurry (-.-) (_wlLine wl)
|
||||
reflectVel = safeNormalizeV $ reflectIn wallV (_btVel' bt)
|
||||
incFlamelets = over worldEvents $ (.) (makeFlameletTimed pOut reflectVel Nothing 3 20)
|
||||
|
||||
{- | Create a shockwave on wall-}
|
||||
bulConWall'
|
||||
:: Particle
|
||||
-> Point2 -- Impact point
|
||||
-> Point2 -- ^ Impact point
|
||||
-> Wall
|
||||
-> World
|
||||
-> World
|
||||
@@ -213,14 +197,13 @@ 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 -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
|
||||
Just hp -> foldr (\j -> (walls . ix j . blHP -~ 5)) w (_blIDs wall)
|
||||
_ -> w
|
||||
wallV = (snd $ _wlLine wl) -.- (fst $ _wlLine wl)
|
||||
mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
|
||||
mkwave = over worldEvents ((makeShockwaveAt [] p 15 4 1 white) . )
|
||||
|
||||
hvBulHitWall'
|
||||
:: Particle
|
||||
-> Point2 -- Impact point
|
||||
-> Point2 -- ^ Impact point
|
||||
-> Wall
|
||||
-> World
|
||||
-> World
|
||||
@@ -231,10 +214,10 @@ hvBulHitWall' bt p x w = damageBlocks x $ set randGen g $ foldr ($) w (sparks p
|
||||
(a, g) = randomR (-0.1,0.1) $ _randGen w
|
||||
spid = newKey $ _projectiles w
|
||||
reflectDir wall = a +
|
||||
argV (reflectIn ((snd $ _wlLine wall) -.- (fst $ _wlLine wall)) (p -.- sp) )
|
||||
argV (reflectIn (uncurry (-.-) (_wlLine wall)) (p -.- sp) )
|
||||
sv = unitVectorAtAngle $ reflectDir x
|
||||
damageBlocks wall w = case wall ^? blHP of
|
||||
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 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
|
||||
@@ -243,10 +226,7 @@ hvBulHitWall' bt p x w = damageBlocks x $ set randGen g $ foldr ($) w (sparks p
|
||||
|
||||
bulHitFF' :: Particle -> Point2 -> ForceField -> World -> World
|
||||
bulHitFF' _ _ _ = id
|
||||
|
||||
{-
|
||||
Typical effect: destroy on impact, damage creatures and blocks, create spark on walls.
|
||||
-}
|
||||
{- | Typical effect: destroy on impact, damage creatures and blocks, create spark on walls. -}
|
||||
basicBulletEffect :: HitEffect
|
||||
basicBulletEffect = destroyOnImpact bulHitCr' bulHitWall' bulHitFF'
|
||||
|
||||
|
||||
@@ -1,3 +1,4 @@
|
||||
{- | Laser effects -}
|
||||
module Dodge.Item.Weapon.Laser
|
||||
where
|
||||
import Dodge.Data
|
||||
@@ -15,6 +16,7 @@ import Picture
|
||||
|
||||
import Control.Lens
|
||||
import System.Random
|
||||
import Data.Tuple
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Sequence as Seq
|
||||
@@ -38,7 +40,6 @@ charToPhaseV 'V' = 0.2
|
||||
charToPhaseV '/' = 1
|
||||
charToPhaseV 'Z' = 5
|
||||
|
||||
|
||||
makeLaserAt :: Float -> Point2 -> Float -> Maybe Int -> Particle
|
||||
makeLaserAt phaseV pos dir mcid = Particle
|
||||
{ _ptDraw = const blank
|
||||
@@ -55,13 +56,12 @@ moveLaser
|
||||
-> (World, Maybe Particle)
|
||||
moveLaser phaseV pos dir mcid w pt
|
||||
= ( set randGen g $ hitEffect w
|
||||
, Just pt {_ptDraw = const $ onLayer PtLayer $ pic ,_ptUpdate' = ptTimer' 0 }
|
||||
, Just pt {_ptDraw = const $ onLayer PtLayer pic ,_ptUpdate' = ptTimer' 0 }
|
||||
)
|
||||
where
|
||||
xp = pos +.+ 800 *.* unitVectorAtAngle dir
|
||||
(a,g) = randomR (-0.7,0.7) $ _randGen w
|
||||
reflectDir wall = a +
|
||||
(argV $ reflectIn ((fst $ _wlLine wall) -.- (snd $ _wlLine wall)) (xp -.- pos) )
|
||||
reflectDir wall = a + argV (reflectIn (uncurry (-.-) (_wlLine wall)) (xp -.- pos))
|
||||
(colID,_) = randomR (0,11) $ _randGen w
|
||||
f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either3 Creature Wall ForceField),[Point2])
|
||||
f seenWs x y = case find (h' seenWs) $ thingsHitExceptCrLongLine Nothing x y w of
|
||||
@@ -76,20 +76,23 @@ moveLaser phaseV pos dir mcid w pt
|
||||
h x y wl p | isEntering = p +.+ rotateV angleRef normalDist
|
||||
| otherwise = p +.+ rotateV angleRef' normalDist'
|
||||
where
|
||||
wlNormal = vNormal $ (snd $ _wlLine wl) -.- (fst $ _wlLine wl)
|
||||
wlNormal = vNormal $ uncurry (-.-) $ swap (_wlLine wl)
|
||||
normalDist = magV (p -.- y) *.* normalizeV wlNormal
|
||||
angleInc = piRange $ argV wlNormal - argV (x -.- y)
|
||||
angleRef | reflectExternal = angleInc
|
||||
| otherwise = asin $ sin angleInc / phaseV
|
||||
piRange a | a > pi = a - 2 * pi
|
||||
| a > negate pi = a
|
||||
| otherwise = a + 2 * pi
|
||||
isEntering = isLeftOf (x -.- y) ((snd $ _wlLine wl) -.- (fst $ _wlLine wl))
|
||||
angleRef
|
||||
| reflectExternal = angleInc
|
||||
| otherwise = asin $ sin angleInc / phaseV
|
||||
piRange a
|
||||
| a > pi = a - 2 * pi
|
||||
| a > negate pi = a
|
||||
| otherwise = a + 2 * pi
|
||||
isEntering = not $ isLeftOf (x -.- y) (uncurry (-.-) (_wlLine wl))
|
||||
wlNormal' = vNormal $ uncurry (-.-) (_wlLine wl)
|
||||
normalDist' = magV (p -.- y) *.* normalizeV wlNormal'
|
||||
angleInc' = piRange $ argV wlNormal' - argV (x -.- y)
|
||||
angleRef' | reflectInternal = angleInc'
|
||||
| otherwise = asin $ phaseV * sin angleInc'
|
||||
angleRef'
|
||||
| reflectInternal = angleInc'
|
||||
| otherwise = asin $ phaseV * sin angleInc'
|
||||
reflectInternal = 1 < abs (phaseV * sin angleInc')
|
||||
reflectExternal = 1 < abs (sin angleInc / phaseV)
|
||||
|
||||
@@ -104,10 +107,11 @@ moveLaser phaseV pos dir mcid w pt
|
||||
Just (p,E3x2 wl) -> createSpark 8 colID (p +.+ safeNormalizeV (pos -.- p))
|
||||
(reflectDir wl) Nothing
|
||||
_ -> id
|
||||
pic = pictures [ fadeLine pos (head ps) 0.2 40 yellow
|
||||
, setLayer 1 $ color (withAlpha 0.9 white) $ vThickLine (pos:ps)
|
||||
, setLayer 1 $ color (withAlpha 0.5 yellow) $ vvThickLine (pos:ps)
|
||||
]
|
||||
pic = pictures
|
||||
[ fadeLine pos (head ps) 0.2 40 yellow
|
||||
, setLayer 1 $ color (withAlpha 0.9 white) $ vThickLine (pos:ps)
|
||||
, setLayer 1 $ color (withAlpha 0.5 yellow) $ vvThickLine (pos:ps)
|
||||
]
|
||||
|
||||
fadeLine :: Point2 -> Point2 -> Float -> Float -> Color -> Picture
|
||||
fadeLine sp ep alph width col = setLayer 1 $ polygonCol
|
||||
|
||||
@@ -351,10 +351,8 @@ torqueAfter torque feff cid w
|
||||
(rot, g) = randomR (-torque,torque) $ _randGen w
|
||||
rotateScope w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
|
||||
. itAttachment . _Just . scopePos %~ rotateV rot
|
||||
{- |
|
||||
Create multiple bullets with a given spread, a given amount, given velocity,
|
||||
given width and given 'HitEffect'.
|
||||
-}
|
||||
{- | Create multiple bullets with a given spread, a given amount, given velocity,
|
||||
given width and given 'HitEffect'. -}
|
||||
spreadNumVelWthHiteff
|
||||
:: Float -- ^ Spread
|
||||
-> Int -- ^ Number of bullets
|
||||
@@ -371,15 +369,13 @@ spreadNumVelWthHiteff spread num vel wth eff cid w = over particles (newbuls ++)
|
||||
(\pos d colid -> aGenBulAt' (Just cid) (numColor colid) pos (rotateV d vel) eff wth)
|
||||
poss dirs colids
|
||||
poss = map ((+.+) $ _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr))
|
||||
$ (replicateM num . randInCirc) 5 & evalState $ _randGen w
|
||||
dirs = map ((+) (_crDir cr))
|
||||
$ zipWith (+) [-spread,-spread+(2*spread/fromIntegral num)..]
|
||||
$ randomRs (0,spread/5) (_randGen w)
|
||||
$ (replicateM num . randInCirc) 5 & evalState $ _randGen w
|
||||
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)
|
||||
{- |
|
||||
Create a number of bullets side by side with a given velocity,
|
||||
given width and given 'HitEffect'.
|
||||
-}
|
||||
{- | Create a number of bullets side by side with a given velocity,
|
||||
given width and given 'HitEffect'. -}
|
||||
numVelWthHitEff
|
||||
:: Int -- ^ Amount of bullets
|
||||
-> Point2 -- ^ Velocity, x axis is direction of creature
|
||||
|
||||
@@ -90,18 +90,17 @@ mvRadar
|
||||
-> Point2 -- ^ Center of expanding circle
|
||||
-> World -> Particle -> (World, Maybe Particle)
|
||||
mvRadar 0 _ w _ = (w, Nothing)
|
||||
mvRadar x p w pt = (putBlips w, Just $ pt {_ptDraw = const pic
|
||||
,_ptUpdate' = mvRadar (x-1) p
|
||||
}
|
||||
)
|
||||
mvRadar x p w pt =
|
||||
( putBlips w
|
||||
, Just $ pt {_ptDraw = const pic ,_ptUpdate' = mvRadar (x-1) p }
|
||||
)
|
||||
where
|
||||
pic = onLayerL [levLayer ShadowLayer, 1] $ pictures $ sweepPics
|
||||
putBlips = over worldEvents ((.) $ over particles ((++) blips))
|
||||
blips = map (\p -> blipAt p (withAlpha (0.5*globalAlpha) red) 50)
|
||||
$ circPoints
|
||||
circPoints = mapMaybe (\wl -> collidePointCircCorrect (fst $ _wlLine wl) (snd $ _wlLine wl) r p)
|
||||
$ (map (over wlLine swp) $ IM.elems $ wallsAlongCirc p r w)
|
||||
++ (IM.elems $ wallsAlongCirc p r w)
|
||||
pic = onLayerL [levLayer ShadowLayer, 1] $ pictures sweepPics
|
||||
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)
|
||||
++ IM.elems (wallsAlongCirc p r w)
|
||||
swp (a,b) = (b,a)
|
||||
r = fromIntegral (800 - x*16)
|
||||
sweepPics = [--colHelper 0.1 $ uncurry translate p $ thickCircle r 15
|
||||
@@ -117,14 +116,14 @@ aTractorBeam
|
||||
-> Int -- ^ Creature id
|
||||
-> World
|
||||
-> World
|
||||
aTractorBeam col cid w
|
||||
= set (creatures . ix cid . crInv . ix itRef . wpFire)
|
||||
(shoot $ aTractorBeam ((col + 1) `mod` 10))
|
||||
$ over projectiles (IM.insert i (tractorBeamAt col i pos dir)) w
|
||||
aTractorBeam col cid w
|
||||
= set (creatures . ix cid . crInv . ix itRef . wpFire)
|
||||
(shoot $ aTractorBeam ((col + 1) `mod` 10))
|
||||
$ over projectiles (IM.insert i (tractorBeamAt col i pos dir)) w
|
||||
where
|
||||
i = newProjectileKey w
|
||||
cr = (_creatures w IM.! cid)
|
||||
pos = _crPos cr +.+ ((_crRad cr +10) *.* unitVectorAtAngle dir)
|
||||
cr = _creatures w IM.! cid
|
||||
pos = _crPos cr +.+ ((_crRad cr + 10) *.* unitVectorAtAngle dir)
|
||||
dir = _crDir cr
|
||||
itRef = _crInvSel cr
|
||||
|
||||
|
||||
@@ -76,7 +76,7 @@ annoToRoomTree [DoorNumAno i,AirlockAno] = airlock i >>= roomThenCorridor
|
||||
annoToRoomTree [FirstWeapon] = do
|
||||
branchWP <- branchRectWith weaponRoom
|
||||
blockedC <- longBlockedCorridor
|
||||
join $ takeOne $ (return $ appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom
|
||||
join $ takeOne $ return (appendEitherTree branchWP [blockedC]) : replicate 5 weaponRoom
|
||||
annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1)
|
||||
annoToRoomTree [StartRoom] = do
|
||||
w <- state $ randomR (100,400)
|
||||
@@ -85,7 +85,7 @@ annoToRoomTree [StartRoom] = do
|
||||
annoToRoomTree (SpecificRoom rt:_) = rt
|
||||
annoToRoomTree (BossAno cr : _) = do
|
||||
br <- bossRoom cr
|
||||
branchRectWith . pure . fmap (Left) $ treeFromPost [corridor,corridor] br
|
||||
branchRectWith . pure . fmap Left $ treeFromPost [corridor,corridor] br
|
||||
annoToRoomTree (TreasureAno crs loot : _) =
|
||||
branchRectWith . fmap (pure . Left) $ lootRoom crs loot
|
||||
annoToRoomTree _ = do
|
||||
|
||||
@@ -26,13 +26,11 @@ shiftRoomTreeSearch
|
||||
shiftRoomTreeSearch _ Empty = Just []
|
||||
shiftRoomTreeSearch bs (Node r ts :<| ts')
|
||||
| roomIsClipping = Nothing
|
||||
| otherwise = fmap (r :) $ shiftRoomTreeSearch newBounds $ ts' >< children
|
||||
| otherwise = fmap (r :) . shiftRoomTreeSearch newBounds $ ts' >< children
|
||||
where
|
||||
roomIsClipping = or (polysIntersect <$> _rmBound r <*> bs)
|
||||
newBounds = _rmBound r ++ bs
|
||||
children = fromList $ zipWith (\l -> applyToRoot (shiftRoomToLink l))
|
||||
(_rmLinks r)
|
||||
ts
|
||||
children = fromList $ zipWith (applyToRoot . shiftRoomToLink) (_rmLinks r) ts
|
||||
{- |
|
||||
All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping.
|
||||
-}
|
||||
@@ -44,7 +42,7 @@ shiftRoomTreeSearchAll _ Empty = [[]]
|
||||
shiftRoomTreeSearchAll bs (Node r ts :<| ts')
|
||||
| roomIsClipping = [] -- this is called too often, but whatever
|
||||
| otherwise = case ts of
|
||||
[] -> (r :) <$> (shiftRoomTreeSearchAll newBounds ts')
|
||||
[] -> (r :) <$> shiftRoomTreeSearchAll newBounds ts'
|
||||
(s:ss) -> concatMap (\l -> shiftRoomTreeSearchAll bs (Node (rm l) ss <| (ts' |> f l s))) ls
|
||||
where
|
||||
ls = init $ _rmLinks r
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
{-
|
||||
{- |
|
||||
Creation of doors that open when creatures approach them.
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
@@ -68,11 +68,12 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr))
|
||||
|
||||
addSound (x:xs) = f x : xs
|
||||
f wl = over doorMech g wl
|
||||
g dm w | dist wp pld > 2 && dist wp hwd > 2
|
||||
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
|
||||
| otherwise = dm w
|
||||
g dm w
|
||||
| dist wp pld > 2 && dist wp hwd > 2
|
||||
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
|
||||
| otherwise = dm w
|
||||
where
|
||||
wp = snd (_wlLine $ _walls w IM.! (head xs))
|
||||
wp = snd (_wlLine $ _walls w IM.! head xs)
|
||||
|
||||
autoDoorPane
|
||||
:: (Point2,Point2) -- ^ Trigger line
|
||||
|
||||
+28
-26
@@ -1,5 +1,5 @@
|
||||
{-
|
||||
Creation, update and descruction of destructible walls.
|
||||
{- |
|
||||
Creation, update and destruction of destructible walls.
|
||||
-}
|
||||
module Dodge.LevelGen.Block where
|
||||
import Dodge.Data
|
||||
@@ -26,17 +26,18 @@ updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) d
|
||||
removeFromZone :: Wall -> World -> World
|
||||
removeFromZone bl = over (wallsZone . ix x . ix y) (IM.delete (_wlID bl))
|
||||
where
|
||||
(x,y) = zoneOfPoint $ pHalf (fst $ _wlLine bl) (snd $ _wlLine bl)
|
||||
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine bl)
|
||||
deadPanes = filter blockIsDead (IM.elems $ _walls w)
|
||||
deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
|
||||
blockIsDead wl = case wl ^? blHP of
|
||||
Just x -> x <= 0
|
||||
Nothing -> False
|
||||
|
||||
{- | Destroy a block.
|
||||
Plays destruction sound and sets to be displayed other walls that were shadowed by this wall. -}
|
||||
killBlock :: Wall -> World -> World
|
||||
killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ w
|
||||
killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ w
|
||||
where
|
||||
f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
|
||||
f bl@Block{_blDegrades = (x:xs)} = degradeBlock bl . hitSound bl
|
||||
f bl = hitSound' bl
|
||||
pos = fst $ _wlLine bl
|
||||
hitSound bl
|
||||
@@ -50,7 +51,7 @@ killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ w
|
||||
unshadow :: Int -> World -> World
|
||||
unshadow bid w = case w ^? walls . ix bid of
|
||||
Just b ->
|
||||
let (x,y) = zoneOfPoint $ pHalf (fst $ _wlLine b) (snd $ _wlLine b)
|
||||
let (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine b)
|
||||
in w & wallsZone . ix x . ix y . ix bid . blVisible %~ const True
|
||||
& walls . ix bid . blVisible %~ const True
|
||||
Nothing -> w
|
||||
@@ -97,33 +98,34 @@ addBlock (p:ps) hp col isSeeThrough degradability w
|
||||
| hp <= 0 && null degradability = w
|
||||
| hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
|
||||
| otherwise = w
|
||||
& wallsZone %~ flip (IM.foldr wallInZone) panes
|
||||
& walls %~ IM.union panes
|
||||
& wallsZone %~ flip (IM.foldr wallInZone) panes
|
||||
& walls %~ IM.union panes
|
||||
where
|
||||
lines = zip (p:ps) (ps ++ [p])
|
||||
i = newKey $ _walls w
|
||||
is = [i.. i + length lines-1]
|
||||
panes = IM.fromList $ zip is
|
||||
$ zipWith (\j (a,b) -> Block { _wlLine = (a,b)
|
||||
, _wlID = j
|
||||
, _wlColor = col
|
||||
, _wlSeen = False
|
||||
, _blIDs = is
|
||||
, _blHP = hp
|
||||
, _wlIsSeeThrough = isSeeThrough
|
||||
, _blVisible = True
|
||||
, _blShadows = []
|
||||
, _blDegrades = degradability
|
||||
}
|
||||
) is lines
|
||||
panes = IM.fromList $ zip is $ zipWith
|
||||
(\j (a,b) -> Block
|
||||
{ _wlLine = (a,b)
|
||||
, _wlID = j
|
||||
, _wlColor = col
|
||||
, _wlSeen = False
|
||||
, _blIDs = is
|
||||
, _blHP = hp
|
||||
, _wlIsSeeThrough = isSeeThrough
|
||||
, _blVisible = True
|
||||
, _blShadows = []
|
||||
, _blDegrades = degradability
|
||||
}
|
||||
) is lines
|
||||
wallInZone wl
|
||||
| dist (fst $ _wlLine wl) (snd $ _wlLine wl) <= 2*zoneSize
|
||||
= insertIMInZone x y wlid 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 $ pHalf (fst $ _wlLine wl) (snd $ _wlLine wl)
|
||||
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
|
||||
wlid = _wlID wl
|
||||
ips = map zoneOfPoint $ divideLine (2*zoneSize) (fst $ _wlLine wl) (snd $ _wlLine wl)
|
||||
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
|
||||
|
||||
putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
|
||||
putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
|
||||
|
||||
@@ -1,28 +1,26 @@
|
||||
{- | Splits a line into many four cornered blocks. -}
|
||||
module Dodge.LevelGen.LineBlock
|
||||
(putLineBlock
|
||||
( putLineBlock
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.LevelGen.Pathing
|
||||
|
||||
import Picture
|
||||
import Geometry
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import qualified Data.IntMap as IM
|
||||
|
||||
-- taken from online, splits a list into its even and odd elements
|
||||
-- | Taken from online, splits a list into its even and odd elements
|
||||
evenOddSplit = foldr f ([],[])
|
||||
where f a (ls,rs) = (rs, a : ls)
|
||||
|
||||
putLineBlock
|
||||
:: Wall -- Base pane
|
||||
-> Float -- Block width
|
||||
-> Float -- Block depth
|
||||
-> Point2 -- Start point (symmetric)
|
||||
-> Point2 -- End point (symmetric)
|
||||
:: Wall -- ^ Base pane
|
||||
-> Float -- ^ Block width
|
||||
-> Float -- ^ Block depth
|
||||
-> Point2 -- ^ Start point (symmetric)
|
||||
-> Point2 -- ^ End point (symmetric)
|
||||
-> World
|
||||
-> World
|
||||
putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr insertBlock w listBlocks
|
||||
@@ -30,7 +28,7 @@ putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr i
|
||||
d = dist a b
|
||||
rot = argV (b -.- a)
|
||||
psOnLine = divideLineOddNumPoints blockWidth a b
|
||||
halfBlockWidth = d / (fromIntegral $ length psOnLine - 1)
|
||||
halfBlockWidth = d / fromIntegral (length psOnLine - 1)
|
||||
blockCenPs = snd $ evenOddSplit psOnLine
|
||||
numBlocks = length blockCenPs
|
||||
is = [0.. numBlocks - 1]
|
||||
|
||||
@@ -132,7 +132,7 @@ cutWalls' qs walls =
|
||||
expandPolyBy :: Float -> [Point2] -> [Point2]
|
||||
expandPolyBy x ps = map f ps
|
||||
where
|
||||
cp = 1/(fromIntegral (length ps)) *.* foldr (+.+) (0,0) ps
|
||||
cp = 1/fromIntegral (length ps) *.* foldr (+.+) (0,0) ps
|
||||
f p = p +.+ x *.* (p -.- cp)
|
||||
-- | Given a polygon expressed as a list of points and a collection of walls,
|
||||
-- returns:
|
||||
@@ -171,7 +171,7 @@ addPolyWall (p1,p2) walls =
|
||||
Just ws -> if all (\(x,y) -> isLHS x y p3) ws
|
||||
then walls
|
||||
else (p1,p2) : walls
|
||||
Nothing -> ((p1,p2) : walls)
|
||||
Nothing -> (p1,p2) : walls
|
||||
where
|
||||
p3 = 0.5 *.* (p1 +.+ p2)
|
||||
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
|
||||
|
||||
+48
-10
@@ -2,23 +2,20 @@ module Dodge.Path where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.Graph
|
||||
|
||||
import Geometry
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Function
|
||||
import Data.Graph.Inductive.Graph
|
||||
import qualified Data.HashSet as HS
|
||||
import qualified Data.Heap as HP
|
||||
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Data.Graph.Inductive.Graph
|
||||
import Data.Graph.Inductive.PatriciaTree
|
||||
import Data.Graph.Inductive.Query.SP
|
||||
import Data.Graph.Inductive.Graph hiding ((&))
|
||||
import qualified Data.HashSet as HS
|
||||
import qualified Data.Heap as HP
|
||||
import qualified Data.Map as M
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
import System.Random
|
||||
|
||||
worldGraph :: World -> Point2 -> HS.HashSet Point2
|
||||
worldGraph w p = HS.unions $ fmap (\q -> HS.fromList $ pointsAlong w p (p +.+ q))
|
||||
@@ -164,3 +161,44 @@ maybeToEither :: a -> Maybe b -> Either a b
|
||||
maybeToEither _ (Just x) = Right x
|
||||
maybeToEither y Nothing = Left y
|
||||
|
||||
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 $ randomGraphWalk [n] g Data.Function.& evalState $ _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 $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w)
|
||||
|
||||
@@ -19,10 +19,10 @@ import Data.Tree
|
||||
import Control.Monad.State
|
||||
import Control.Lens
|
||||
import System.Random
|
||||
roomOctogon
|
||||
roomGlassOctogon
|
||||
:: Float -- ^ Size
|
||||
-> Room
|
||||
roomOctogon x = Room
|
||||
roomGlassOctogon x = Room
|
||||
{ _rmPolys = [rectNSWE x (-x) (-x) x
|
||||
,rectNSWE 0 (-(x + 40)) (-20) 20
|
||||
]
|
||||
@@ -63,7 +63,7 @@ armouredChasers = do
|
||||
|
||||
randomMediumRoom :: RandomGen g => State g Room
|
||||
randomMediumRoom = takeOne
|
||||
[ roomOctogon 300
|
||||
[ roomGlassOctogon 300
|
||||
, roomCross 180 300
|
||||
, roomShuriken 200 300
|
||||
, roomTwistCross 230 300 0
|
||||
|
||||
@@ -1,6 +1,5 @@
|
||||
{-
|
||||
Procedural creation of rooms and subroom parts.
|
||||
-}
|
||||
{- |
|
||||
Procedural creation of rooms and subroom parts. -}
|
||||
module Dodge.Room.Procedural
|
||||
( roomRect
|
||||
, roomRectAutoLinks
|
||||
@@ -24,6 +23,7 @@ import Picture
|
||||
|
||||
import Data.List (nub,nubBy,sortBy,minimumBy)
|
||||
import Data.Function (on)
|
||||
import qualified Data.Tuple.Extra as Tup
|
||||
import qualified Data.Map as M
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
@@ -49,10 +49,10 @@ roomRect x y xn yn = Room
|
||||
where
|
||||
yd = (y - 40) / fromIntegral yn
|
||||
xd = (x - 40) / fromIntegral xn
|
||||
elnks = flip zip (repeat ( pi/2)) $ translateS (0,20) $ gridPoints 0 1 yd (yn+1)
|
||||
wlnks = flip zip (repeat (-pi/2)) $ translateS (x,20) $ gridPoints 0 1 yd (yn+1)
|
||||
nlnks = flip zip (repeat ( 0)) $ translateS (20,y) $ gridPoints xd (xn+1) 0 1
|
||||
slnks = flip zip (repeat ( pi)) $ translateS (20,0) $ gridPoints xd (xn+1) 0 1
|
||||
elnks = zip (translateS (0,20) $ gridPoints 0 1 yd (yn+1)) (repeat ( pi/2))
|
||||
wlnks = zip (translateS (x,20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2))
|
||||
nlnks = zip (translateS (20,y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 )
|
||||
slnks = zip (translateS (20,0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi )
|
||||
lnks = nlnks ++ elnks ++ wlnks ++ slnks
|
||||
pth = linksAndPath lnks $ translateS (20,20) (makeGrid xd xn yd yn)
|
||||
{-
|
||||
@@ -65,7 +65,7 @@ makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)]
|
||||
makeGrid x nx y ny
|
||||
= nub
|
||||
. concatMap doublePair
|
||||
. concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y)
|
||||
. concatMap (\p -> map (Tup.both (p +.+)) $ makeRect x y)
|
||||
$ gridPoints x nx y ny
|
||||
|
||||
gridPoints :: Float -> Int -> Float -> Int -> [Point2]
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
{-
|
||||
{- |
|
||||
Creation of particles in the world.
|
||||
-}
|
||||
module Dodge.WorldEvent.SpawnParticle
|
||||
@@ -26,6 +26,7 @@ import Control.Monad.State
|
||||
import Data.Function (on)
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Tuple
|
||||
|
||||
aFlameParticle
|
||||
:: Int -- ^ Timer
|
||||
@@ -126,9 +127,8 @@ moveFlame rotd w pt
|
||||
, _btVel' = reflV wl
|
||||
}
|
||||
pOut p = p +.+ safeNormalizeV (sp -.- p)
|
||||
reflV wall = (0.3 *.* reflectIn ((snd $ _wlLine wall) -.- (fst $ _wlLine wall)) vel )
|
||||
+.+
|
||||
(0.2 *.* vel)
|
||||
reflV wall = (0.3 *.* reflectIn (uncurry (-.-) . swap $ _wlLine wall) vel )
|
||||
+.+ (0.2 *.* vel)
|
||||
smokeGen = makeFlamerSmokeAt ep
|
||||
|
||||
makeFlameletTimed
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
{-
|
||||
{- |
|
||||
Find which objects lie upon a line.
|
||||
-}
|
||||
module Dodge.WorldEvent.ThingsHit
|
||||
@@ -11,9 +11,7 @@ import qualified Data.IntMap.Strict as IM
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Function (on)
|
||||
{-
|
||||
List those objects that appear on a line.
|
||||
-}
|
||||
{- List those objects that appear on a line. -}
|
||||
thingsHit
|
||||
:: Point2 -- ^ Line start point
|
||||
-> Point2 -- ^ Line end point
|
||||
@@ -23,26 +21,24 @@ thingsHit sp ep w
|
||||
| sp == ep = []
|
||||
| otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
|
||||
where
|
||||
hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
|
||||
$ _creatures w
|
||||
-- $ creaturesAlongLine sp ep w
|
||||
hitCrs = IM.elems
|
||||
$ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
|
||||
$ _creatures w
|
||||
-- $ creaturesAlongLine sp ep w
|
||||
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
|
||||
crs = zip crPs (map E3x1 hitCrs)
|
||||
|
||||
hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1]
|
||||
, b<-[y-1,y,y+1]])
|
||||
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
|
||||
f i m = case IM.lookup i m of Just val -> val
|
||||
_ -> IM.empty
|
||||
f i m = case IM.lookup i m of
|
||||
Just val -> val
|
||||
_ -> IM.empty
|
||||
walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
|
||||
hitPoint w = intersectSegSeg' sp ep (fst $ _wlLine w) (snd $ _wlLine w)
|
||||
hitPoint w = uncurry (intersectSegSeg' sp ep) (_wlLine w)
|
||||
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
|
||||
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
|
||||
|
||||
{-
|
||||
List objects that appear on a line.
|
||||
Can filter out a creature.
|
||||
-}
|
||||
{- List objects that appear on a line.
|
||||
Can filter out a creature. -}
|
||||
thingsHitExceptCr
|
||||
:: Maybe Int -- ^ A possible creature ID
|
||||
-> Point2 -- ^ Line start point
|
||||
@@ -55,28 +51,32 @@ thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep
|
||||
crNotCid (_,E3x1 cr) = _crID cr /= cid
|
||||
crNotCid _ = True
|
||||
|
||||
thingsHitExceptCrLongLine :: Maybe Int -> Point2 -> Point2 -> World
|
||||
-> [(Point2, Either3 Creature Wall ForceField)]
|
||||
thingsHitExceptCrLongLine
|
||||
:: Maybe Int
|
||||
-> Point2
|
||||
-> Point2
|
||||
-> World
|
||||
-> [(Point2, Either3 Creature Wall ForceField)]
|
||||
thingsHitExceptCrLongLine Nothing sp ep = thingsHitLongLine sp ep
|
||||
thingsHitExceptCrLongLine (Just cid) sp ep = filter crNotCid . thingsHitLongLine sp ep
|
||||
where crNotCid (_,E3x1 cr) = _crID cr /= cid
|
||||
crNotCid _ = True
|
||||
where
|
||||
crNotCid (_,E3x1 cr) = _crID cr /= cid
|
||||
crNotCid _ = True
|
||||
|
||||
thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, Either3 Creature Wall ForceField)]
|
||||
thingsHitLongLine sp ep w
|
||||
| sp == ep = []
|
||||
| otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
|
||||
| otherwise = sortOn (dist sp . fst) (crs ++ walls ++ ffs)
|
||||
where
|
||||
crs = zip crPs (map E3x1 hitCrs)
|
||||
hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
|
||||
$ _creatures w
|
||||
-- $ creaturesAlongLine sp ep w
|
||||
hitCrs = IM.elems
|
||||
. IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
|
||||
$ _creatures w
|
||||
-- $ creaturesAlongLine sp ep w
|
||||
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
|
||||
|
||||
walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
|
||||
hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
|
||||
hitPoint wl = intersectSegSeg' sp ep (fst $ _wlLine wl) (snd $ _wlLine wl)
|
||||
|
||||
hitPoint wl = uncurry (intersectSegSeg' sp ep) (_wlLine wl)
|
||||
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
|
||||
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
|
||||
|
||||
|
||||
Reference in New Issue
Block a user