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

Refactor

Browse Source
This commit is contained in:
jgk
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
- directory
- QuickCheck
- extra
library:
source-dirs: src
src/Dodge/AIs.hs
+184 -342
View File
@@ -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,8 +1629,8 @@ 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
replaceGoal newGoals = Just . over (crState . goals) (\gs -> newGoals ++ tail gs)
@@ -1628,64 +1639,40 @@ sniperAI w (f,g) cr =
= 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
)
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
)
| 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 )
| 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
(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
@@ -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)
src/Dodge/Creature.hs
+3 -1
View File
@@ -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
src/Dodge/Creature/Action.hs
+3 -8
View File
@@ -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
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 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
src/Dodge/Creature/Property.hs
-1
View File
@@ -1,7 +1,6 @@
module Dodge.Creature.Property
where
import Dodge.Data
import Geometry
import Control.Lens
src/Dodge/Creature/State/Data.hs
+1
View File
@@ -86,6 +86,7 @@ data Carriage
= Walking { _stepCycle :: Int, _stepToAdd :: Int }
| Standing
| Floating
| Flying
| Boosting Point2
deriving (Eq,Show)
data Posture = Aiming | AtEase
src/Dodge/Creature/YourControl.hs
+9 -9
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
)
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,22 +61,22 @@ 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
Just (Just ItScope{_scopePos = p}) -> normalizeAngle $ argV
$ p +.+ 2 / _cameraZoom w
*.* rotateV (_cameraRot w) (_mousePos w)
_ -> normalizeAngle $ argV (_mousePos w) + _cameraRot w
src/Dodge/Event/Keyboard.hs
+1 -1
View File
@@ -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
src/Dodge/Floor.hs
+4
View File
@@ -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]
src/Dodge/Item/Consumable.hs
+1 -1
View File
@@ -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
src/Dodge/Item/Weapon.hs
+12 -8
View File
@@ -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)
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,11 +1018,16 @@ 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)
$ set (itPoint . wpFire) (const id)
$ resetName
$ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w
where
@@ -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
src/Dodge/Item/Weapon/Bullet.hs
+23 -43
View File
@@ -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'
src/Dodge/Item/Weapon/Laser.hs
+14 -10
View File
@@ -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,19 +76,22 @@ 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
angleRef
| reflectExternal = angleInc
| otherwise = asin $ sin angleInc / phaseV
piRange a | a > pi = a - 2 * pi
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))
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'
angleRef'
| reflectInternal = angleInc'
| otherwise = asin $ phaseV * sin angleInc'
reflectInternal = 1 < abs (phaseV * sin angleInc')
reflectExternal = 1 < abs (sin angleInc / phaseV)
@@ -104,7 +107,8 @@ 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
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)
]
src/Dodge/Item/Weapon/TriggerType.hs
+7 -11
View File
@@ -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
@@ -372,14 +370,12 @@ spreadNumVelWthHiteff spread num vel wth eff cid w = over particles (newbuls ++)
poss dirs colids
poss = map ((+.+) $ _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr))
$ (replicateM num . randInCirc) 5 & evalState $ _randGen w
dirs = map ((+) (_crDir cr))
$ zipWith (+) [-spread,-spread+(2*spread/fromIntegral num)..]
$ randomRs (0,spread/5) (_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
src/Dodge/Item/Weapon/UseEffect.hs
+10 -11
View File
@@ -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
@@ -123,7 +122,7 @@ aTractorBeam col cid w
$ over projectiles (IM.insert i (tractorBeamAt col i pos dir)) w
where
i = newProjectileKey w
cr = (_creatures w IM.! cid)
cr = _creatures w IM.! cid
pos = _crPos cr +.+ ((_crRad cr + 10) *.* unitVectorAtAngle dir)
dir = _crDir 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
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
src/Dodge/Layout/Tree/Shift.hs
+3 -5
View File
@@ -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
src/Dodge/LevelGen/AutoDoor.hs
+4 -3
View File
@@ -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
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
src/Dodge/LevelGen/Block.hs
+13 -11
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
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
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
@@ -103,8 +104,9 @@ addBlock (p:ps) hp col isSeeThrough degradability w
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)
panes = IM.fromList $ zip is $ zipWith
(\j (a,b) -> Block
{ _wlLine = (a,b)
, _wlID = j
, _wlColor = col
, _wlSeen = False
@@ -117,13 +119,13 @@ addBlock (p:ps) hp col isSeeThrough degradability w
}
) is lines
wallInZone wl
| dist (fst $ _wlLine wl) (snd $ _wlLine wl) <= 2*zoneSize
| 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
src/Dodge/LevelGen/LineBlock.hs
+8 -10
View File
@@ -1,3 +1,4 @@
{- | Splits a line into many four cornered blocks. -}
module Dodge.LevelGen.LineBlock
( putLineBlock
)
@@ -5,24 +6,21 @@ module Dodge.LevelGen.LineBlock
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]
src/Dodge/LevelGen/StaticWalls.hs
+2 -2
View File
@@ -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)
src/Dodge/Path.hs
+48 -10
View File
@@ -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)
src/Dodge/Room/Boss.hs
+3 -3
View File
@@ -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
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
( 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]
src/Dodge/WorldEvent/SpawnParticle.hs
+4 -4
View File
@@ -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
src/Dodge/WorldEvent/ThingsHit.hs
+20 -20
View File
@@ -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))
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
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
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
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))
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