justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor

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