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

Refactor, try to limit dependencies

Browse Source
This commit is contained in:
justin
2022-07-28 00:59:56 +01:00
parent 8aa5c17ab9
commit 160560af5f
418 changed files with 15105 additions and 13343 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appDodge/Main.hs
-4
View File
@@ -10,7 +10,6 @@ import Dodge.Initialisation
import Dodge.Update
import Dodge.Event
import Dodge.Render
import Dodge.Config.KeyConfig
import Dodge.Config.Load
import Dodge.Config.Update
import Dodge.SoundLogic.LoadSound
@@ -20,7 +19,6 @@ import Preload.Render
import Sound
import Preload
import Music
import Data.Preload
import Data.Preload.Render
import Control.Lens
@@ -73,7 +71,6 @@ theCleanup uv = SDL.cursorVisible $= True >> cleanUpPreload (_preloadData uv)
firstWorldLoad :: Configuration -> IO Universe
firstWorldLoad theConfig = do
SDL.cursorVisible $= False
theKeyConfig <- loadKeyConfig
pdata <- doPreload >>= applyWorldConfig theConfig
return $ startNewGame $ Universe
{_uvWorld = initialWorld
@@ -81,7 +78,6 @@ firstWorldLoad theConfig = do
,_preloadData = pdata
,_menuLayers = []
,_savedWorlds = M.empty
,_keyConfig = theKeyConfig
, _uvIOEffects = return
, _uvTestString = testStringInit
}
src/Dodge/Annotation.hs
+1 -1
View File
@@ -7,7 +7,7 @@ module Dodge.Annotation
import Dodge.Cleat
import RandomHelp
import Dodge.Tree
import Dodge.Data
import Dodge.Data.GenWorld
import Dodge.Annotation.Data
import LensHelp
src/Dodge/Annotation/Data.hs
+1 -3
View File
@@ -1,9 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Annotation.Data where
import Dodge.Data
--import Dodge.Room
--import TreeHelp
import Dodge.Data.GenWorld
import Dodge.Tree.Compose.Data
import Control.Monad.State
src/Dodge/ArcStep.hs
+3 -2
View File
@@ -1,8 +1,9 @@
module Dodge.ArcStep where
import Dodge.Data
import Dodge.Tesla.Arc.Default
import Control.Monad.State
import Dodge.Data.ArcStep
import Dodge.Data.World
import Dodge.Tesla.Arc.Default
import System.Random
doStep :: NextArcStep -> ItemParams -> World -> ArcStep -> State StdGen (Maybe ArcStep)
src/Dodge/Barreloid.hs
+33 -27
View File
@@ -1,14 +1,14 @@
module Dodge.Barreloid where
import Dodge.Data
import Dodge.WorldEvent.Explosion
import Dodge.Spark
import Dodge.Creature.State
import Geometry
import Dodge.SoundLogic
import LensHelp
import System.Random
import Data.List
import Dodge.Creature.State
import Dodge.Data.World
import Dodge.SoundLogic
import Dodge.Spark
import Dodge.WorldEvent.Explosion
import Geometry
import LensHelp
import System.Random
updateBarreloid :: Creature -> World -> World
updateBarreloid cr = case cr ^?! crType . barrelType of
@@ -19,44 +19,50 @@ updateBarreloid cr = case cr ^?! crType . barrelType of
updateExpBarrel :: Creature -> World -> World
updateExpBarrel cr w
| _crHP cr > 0 = foldr ($) (hiss w & cWorld . creatures . at (_crID cr) .~ newCr) pierceSparks
| otherwise = makeExplosionAt (_crPos cr) $ stopSounds w & cWorld . creatures . at (_crID cr) .~ Nothing
| otherwise = makeExplosionAt (_crPos cr) $ stopSounds w & cWorld . creatures . at (_crID cr) .~ Nothing
where
g = _randGen w
damages = _csDamage $ _crState cr
pierceSparks :: [World -> World]
pierceSparks
= zipWith3 (\p a -> createBarrelSpark (_crPos cr +.+ p) (a + argV p))
poss as colids
as = randomRs (-0.7,0.7) g
colids = randomRs (0,11) g
pierceSparks =
zipWith3
(\p a -> createBarrelSpark (_crPos cr +.+ p) (a + argV p))
poss
as
colids
as = randomRs (-0.7, 0.7) g
colids = randomRs (0, 11) g
poss = _piercedPoints $ _csSpState $ _crState cr
newCr = Just $ applyFuseDamage $ set (crState . csDamage) [] $ damToExpBarrel damages cr
applyFuseDamage cr' = cr' & crHP %~
subtract (length . _piercedPoints . _csSpState $ _crState cr')
hiss | null poss = id
| otherwise = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] (_crPos cr) foamSprayLoopS (Just 1)
applyFuseDamage cr' =
cr' & crHP
%~ subtract (length . _piercedPoints . _csSpState $ _crState cr')
hiss
| null poss = id
| otherwise = soundMultiFrom [BarrelHiss 0, BarrelHiss 1] (_crPos cr) foamSprayLoopS (Just 1)
stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1)
updateBarrel :: Creature -> World -> World
updateBarrel cr
| _crHP cr > 0 = doDamage cr
| otherwise = cWorld . creatures . at (_crID cr) .~ Nothing
| otherwise = cWorld . creatures . at (_crID cr) .~ Nothing
damToExpBarrel :: [Damage] -> Creature -> Creature
damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam) otherDam
where
(pierceDam,otherDam) = partition isPierce ds
(pierceDam, otherDam) = partition isPierce ds
isPierce Damage{_dmType = PIERCING{}} = True
isPierce _ = False
isPierce _ = False
damToExpBarrel' :: Damage -> Creature -> Creature
damToExpBarrel' dm cr = case _dmType dm of
PIERCING -> over (crState . csSpState . piercedPoints) ((:) $ int -.- _crPos cr)
$ cr & crHP -~ div amount 200
POISONDAM -> cr
SPARKING -> cr
-- PUSHDAM -> cr LensHelp.& crPos .+.+~ (1 / _crMass cr *.* _dePushBack (_dmEffect dm))
_ -> cr LensHelp.& crHP -~ amount
PIERCING ->
over (crState . csSpState . piercedPoints) ((:) $ int -.- _crPos cr) $
cr & crHP -~ div amount 200
POISONDAM -> cr
SPARKING -> cr
-- PUSHDAM -> cr LensHelp.& crPos .+.+~ (1 / _crMass cr *.* _dePushBack (_dmEffect dm))
_ -> cr LensHelp.& crHP -~ amount
where
amount = _dmAmount dm
int = _dmAt dm
src/Dodge/Base/CardinalPoint.hs
+6 -7
View File
@@ -1,15 +1,14 @@
module Dodge.Base.CardinalPoint where
import Dodge.Data.Room
import Geometry
cardList :: [CardinalPoint]
cardList = [North,East,South,West]
cardList = [North, East, South, West]
cardVec :: CardinalPoint -> Point2
cardVec cp = case cp of
North -> V2 0 1
South -> V2 0 (-1)
East -> V2 1 0
West -> V2 (-1) 0
North -> V2 0 1
South -> V2 0 (-1)
East -> V2 1 0
West -> V2 (-1) 0
src/Dodge/Base/Collide.hs
+169 -125
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE TupleSections #-}
{- | Basic collision detection for a moving point.
- Conventions: input is typically a stream of walls.
- Collide returns an endpoint and maybe a collided with
@@ -8,49 +9,48 @@
- Overlap returns a stream of walls.
- A point will typically be moving.
- A ball refers to a moving circle, i.e. a point with a radius.
- -}
module Dodge.Base.Collide
( collidePoint
, collideSegCrs
, collidePointWallsFilterStream
, collidePointTestFilter
, overlapSegWalls
, overlapSegCrs
, overlap1SegCrs
, bounceBall
, bouncePoint
, sortStreamOn
, minStreamOn
, collideCircWallsStream
, circOnSomeWall
, circOnAnyCr
, overlapCircWalls
, overlapCircWallsClosest
, crsNearPoint
, allVisibleWalls
, hasLOS
, hasLOSIndirect
, hasButtonLOS
, canSee
, canSeeIndirect
, isWalkable
, anythingHitCirc
) where
import Dodge.Data
import Dodge.Zoning
import Dodge.Base.Wall
import Geometry
import FoldableHelp
-
-}
module Dodge.Base.Collide (
collidePoint,
collideSegCrs,
collidePointWallsFilterStream,
collidePointTestFilter,
overlapSegWalls,
overlapSegCrs,
overlap1SegCrs,
bounceBall,
bouncePoint,
sortStreamOn,
minStreamOn,
collideCircWallsStream,
circOnSomeWall,
circOnAnyCr,
overlapCircWalls,
overlapCircWallsClosest,
crsNearPoint,
allVisibleWalls,
hasLOS,
hasLOSIndirect,
hasButtonLOS,
canSee,
canSeeIndirect,
isWalkable,
anythingHitCirc,
) where
import Control.Lens
import qualified Data.IntSet as IS
import Data.List (sortOn)
import Data.Maybe
import Dodge.Base.Wall
import Dodge.Data.World
import Dodge.Zoning
import FoldableHelp
import Geometry
import qualified IntMapHelp as IM
import Control.Lens
import StreamingHelp
import qualified Streaming.Prelude as S
import qualified Data.IntSet as IS
import StreamingHelp
--collidePoint :: Point2 -> Point2
-- -> StreamOf Wall
@@ -60,54 +60,69 @@ import qualified Data.IntSet as IS
-- where
-- findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
collidePoint :: Point2 -> Point2
-> [Wall]
-> (Point2, Maybe Wall)
collidePoint ::
Point2 ->
Point2 ->
[Wall] ->
(Point2, Maybe Wall)
{-# INLINE collidePoint #-}
collidePoint sp ep = foldl' findPoint (ep, Nothing)
where
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
findPoint (p, mwl) wl = maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
overlap1SegCrs :: Point2 -> Point2
-> [Creature]
-> [(Point2, Creature)]
overlap1SegCrs ::
Point2 ->
Point2 ->
[Creature] ->
[(Point2, Creature)]
{-# INLINE overlap1SegCrs #-}
overlap1SegCrs sp ep = mapMaybe
(\cr -> (,cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep ))
overlap1SegCrs sp ep =
mapMaybe
(\cr -> (,cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
overlapSegCrs :: Point2 -> Point2
-> StreamOf Creature
-> StreamOf ([Point2], Creature)
overlapSegCrs ::
Point2 ->
Point2 ->
StreamOf Creature ->
StreamOf ([Point2], Creature)
{-# INLINE overlapSegCrs #-}
overlapSegCrs sp ep = S.mapMaybe
(\cr -> f cr $ intersectCircSeg (_crPos cr) (_crRad cr) sp ep )
overlapSegCrs sp ep =
S.mapMaybe
(\cr -> f cr $ intersectCircSeg (_crPos cr) (_crRad cr) sp ep)
where
f _ [] = Nothing
f cr ps = Just (ps,cr)
f _ [] = Nothing
f cr ps = Just (ps, cr)
collideSegCrs :: Point2 -> Point2
-> StreamOf Creature
-> (Point2, Maybe Creature)
collideSegCrs ::
Point2 ->
Point2 ->
StreamOf Creature ->
(Point2, Maybe Creature)
{-# INLINE collideSegCrs #-}
collideSegCrs sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id
where
findPoint (p,mcr) cr
= maybe (p,mcr) (,Just cr) $ listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp p)
findPoint (p, mcr) cr =
maybe (p, mcr) (,Just cr) $ listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp p)
doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2)
{-# INLINE doBounce #-}
doBounce x sp ep (p, mwl) = mwl <&> \wl ->
( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
, reflVelWallDamp x wl (ep -.- sp)
)
doBounce x sp ep (p, mwl) =
mwl <&> \wl ->
( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
, reflVelWallDamp x wl (ep -.- sp)
)
bounceBall :: Float -> Point2 -> Point2 -> Float
-> [Wall]
-> Maybe (Point2,Point2)
bounceBall ::
Float ->
Point2 ->
Point2 ->
Float ->
[Wall] ->
Maybe (Point2, Point2)
{-# INLINE bounceBall #-}
bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r
bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2, Point2)
{-# INLINE bouncePoint #-}
bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep
@@ -115,9 +130,9 @@ bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep
-- whether this is actually faster
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> [Wall] -> Bool
{-# INLINE collidePointTestFilter #-}
collidePointTestFilter t sp ep
= any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
. filter t
collidePointTestFilter t sp ep =
any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
. filter t
---- this COULD be written in terms of collidePointWallsFilterStream, TODO test
---- whether this is actually faster
@@ -129,25 +144,27 @@ collidePointTestFilter t sp ep
collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
{-# INLINE collidePointWallsFilterStream #-}
collidePointWallsFilterStream t sp ep = collidePoint sp ep
. filter t
. wlsNearSeg sp ep
collidePointWallsFilterStream t sp ep =
collidePoint sp ep
. filter t
. wlsNearSeg sp ep
--overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
-- -> StreamOf (Point2,Wall)
--{-# INLINE overlapSegWalls #-}
--overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
overlapSegWalls :: Point2 -> Point2 -> [Wall] -> [(Point2,Wall)]
overlapSegWalls :: Point2 -> Point2 -> [Wall] -> [(Point2, Wall)]
{-# INLINE overlapSegWalls #-}
overlapSegWalls sp ep = mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
visibleWalls :: Point2 -> Point2 -> World -> [(Point2,Wall)]
visibleWalls :: Point2 -> Point2 -> World -> [(Point2, Wall)]
{-# INLINE visibleWalls #-}
visibleWalls sp ep = takeUntil (not . wlIsOpaque . snd)
. sortOn (dist sp . fst)
. overlapSegWalls sp ep
. wlsNearSeg sp ep
visibleWalls sp ep =
takeUntil (not . wlIsOpaque . snd)
. sortOn (dist sp . fst)
. overlapSegWalls sp ep
. wlsNearSeg sp ep
--visibleWalls :: Point2 -> Point2 -> World -> StreamOf (Point2,Wall)
--{-# INLINE visibleWalls #-}
@@ -157,7 +174,7 @@ visibleWalls sp ep = takeUntil (not . wlIsOpaque . snd)
-- . overlapSegWalls sp ep
-- . wlsNearSeg sp ep )
allVisibleWalls :: World -> [(Point2,Wall)]
allVisibleWalls :: World -> [(Point2, Wall)]
{-# INLINE allVisibleWalls #-}
allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays 20
where
@@ -177,49 +194,67 @@ allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays
-- dointersect wl = f (_wlLine wl) <&> (,wl)
-- f (a,b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
overlapCircWalls :: Point2 -> Float -> [Wall]
-> [(Point2,Wall)]
overlapCircWalls ::
Point2 ->
Float ->
[Wall] ->
[(Point2, Wall)]
{-# INLINE overlapCircWalls #-}
overlapCircWalls p r = mapMaybe dointersect
where
dointersect wl = f (_wlLine wl) <&> (,wl)
f (a,b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
f (a, b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
-- | note that this does not push the circle away from the wall at all
collideCircWalls :: Point2 -> Point2 -> Float -> [Wall] -> (Point2, Maybe Wall)
{-# INLINE collideCircWalls #-}
collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
where
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
. shiftbyrad
. _wlLine $ wl
shiftbyrad (a,b) = bimap f f
(a +.+ rad *.* normalizeV (a -.-b)
,b +.+ rad *.* normalizeV (b -.-a)
)
findPoint (p, mwl) wl =
maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
. shiftbyrad
. _wlLine
$ wl
shiftbyrad (a, b) =
bimap
f
f
( a +.+ rad *.* normalizeV (a -.- b)
, b +.+ rad *.* normalizeV (b -.- a)
)
where
f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
-- | note that this does not push the circle away from the wall at all
collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall
-> (Point2, Maybe Wall)
collideCircWallsStream ::
Point2 ->
Point2 ->
Float ->
StreamOf Wall ->
(Point2, Maybe Wall)
{-# INLINE collideCircWallsStream #-}
collideCircWallsStream sp ep rad = runIdentity . S.fold_ findPoint (ep, Nothing) id
where
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
. shiftbyrad
. _wlLine $ wl
shiftbyrad (a,b) = bimap f f
(a +.+ rad *.* normalizeV (a -.-b)
,b +.+ rad *.* normalizeV (b -.-a)
)
findPoint (p, mwl) wl =
maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
. shiftbyrad
. _wlLine
$ wl
shiftbyrad (a, b) =
bimap
f
f
( a +.+ rad *.* normalizeV (a -.- b)
, b +.+ rad *.* normalizeV (b -.- a)
)
where
f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2,Wall)
overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2, Wall)
{-# INLINE overlapCircWallsClosest #-}
overlapCircWallsClosest p r = safeMinimumOn (dist p . fst)
. overlapCircWalls p r
overlapCircWallsClosest p r =
safeMinimumOn (dist p . fst)
. overlapCircWalls p r
--overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
--{-# INLINE overlapCircWallsClosest #-}
@@ -227,11 +262,13 @@ overlapCircWallsClosest p r = safeMinimumOn (dist p . fst)
-- . overlapCircWalls p r
{- | Test if a circle collides with any wall.
- Note no check on whether the wall is walkable. -}
- Note no check on whether the wall is walkable.
-}
circOnSomeWall :: Point2 -> Float -> World -> Bool
{-# INLINE circOnSomeWall #-}
circOnSomeWall p rad = any (uncurry (circOnSeg p rad) . _wlLine)
. wlsNearPoint p
circOnSomeWall p rad =
any (uncurry (circOnSeg p rad) . _wlLine)
. wlsNearPoint p
--circOnSomeWall :: Point2 -> Float -> World -> Bool
--{-# INLINE circOnSomeWall #-}
@@ -244,38 +281,41 @@ circOnAnyCr p r w = IS.foldr f False $ crIXsNearPoint p w
where
f cid bl = maybe False (\cr -> dist p (_crPos cr) < r + _crRad cr) (w ^? cWorld . creatures . ix cid) || bl
{- | More general collision tests follow -}
-- | More general collision tests follow
hasLOS :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasLOS #-}
hasLOS p1 p2 = not
. collidePointTestFilter (const True) p1 p2
. wlsNearSeg p1 p2
hasLOS p1 p2 =
not
. collidePointTestFilter (const True) p1 p2
. wlsNearSeg p1 p2
hasButtonLOS :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasButtonLOS #-}
hasButtonLOS p1 p2 = not
. collidePointTestFilter (not . _wlTouchThrough) p1 p2
. wlsNearSeg p1 p2
hasButtonLOS p1 p2 =
not
. collidePointTestFilter (not . _wlTouchThrough) p1 p2
. wlsNearSeg p1 p2
hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasLOSIndirect #-}
hasLOSIndirect p1 p2 = not
. collidePointTestFilter wlIsOpaque p1 p2
. wlsNearSeg p1 p2
hasLOSIndirect p1 p2 =
not
. collidePointTestFilter wlIsOpaque p1 p2
. wlsNearSeg p1 p2
isWalkable :: Point2 -> Point2 -> World -> Bool
{-# INLINE isWalkable #-}
isWalkable p1 p2 = not
. collidePointTestFilter (not . (^?! wlPathable)) p1 p2
. wlsNearSeg p1 p2
isWalkable p1 p2 =
not
. collidePointTestFilter (not . (^?! wlPathable)) p1 p2
. wlsNearSeg p1 p2
canSee :: Int -> Int -> World -> Bool
{-# INLINE canSee #-}
canSee i j w = hasLOS p1 p2 w
where
p1 = _crPos (_creatures (_cWorld w) IM.! i)
p2 = _crPos (_creatures (_cWorld w) IM.! j) -- unsafe
p2 = _crPos (_creatures (_cWorld w) IM.! j) -- unsafe
canSeeIndirect :: Int -> Int -> World -> Bool
{-# INLINE canSeeIndirect #-}
@@ -287,10 +327,14 @@ canSeeIndirect i j w = hasLOSIndirect ipos jpos w
anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
where
hitCr = IS.foldr f False $ crsNearSeg sp ep w
f cid bl = maybe False (\cr -> null $ intersectCircSeg (_crPos cr) (rad + _crRad cr) sp ep)
hitCr = IS.foldr f False $ crsNearSeg sp ep w
f cid bl =
maybe
False
(\cr -> null $ intersectCircSeg (_crPos cr) (rad + _crRad cr) sp ep)
(w ^? cWorld . creatures . ix cid)
|| bl
|| bl
hitWl = collideCircWalls sp ep rad $ wlsNearPoint ep w
-- this should probably be wallsOnLine or something
hitWl = collideCircWalls sp ep rad $ wlsNearPoint ep w
-- this should probably be wallsOnLine or something
src/Dodge/Base/Coordinate.hs
+32 -22
View File
@@ -1,38 +1,48 @@
module Dodge.Base.Coordinate where
import Dodge.Data
import Dodge.Base.WinScale
import Dodge.Base.WinScale
import Dodge.Data.Universe
import Geometry
{- | Transform coordinates from world position to screen coordinates. -}
-- | Transform coordinates from world position to screen coordinates.
worldPosToScreenNorm :: Configuration -> World -> Point2 -> Point2
worldPosToScreenNorm cfig w = doWindowScale cfig . doRotate . doZoom . doTranslate
where
doTranslate p = p -.- _cameraCenter (_cWorld w)
doZoom p = _cameraZoom (_cWorld w) *.* p
doRotate p = rotateV (negate $ _cameraRot (_cWorld w)) p
doZoom p = _cameraZoom (_cWorld w) *.* p
doRotate p = rotateV (negate $ _cameraRot (_cWorld w)) p
{- | Transform world coordinates to scaled screen coordinates.
- These have to be scaled according to the size of the window to get actual screen positions.
- This allows for line thicknesses etc to correspond to pixel sizes.-}
- This allows for line thicknesses etc to correspond to pixel sizes.
-}
worldPosToScreen :: World -> Point2 -> Point2
worldPosToScreen w
= rotateV (negate $ _cameraRot (_cWorld w))
. (_cameraZoom (_cWorld w) *.*)
. (-.- _cameraCenter (_cWorld w))
worldPosToScreen w =
rotateV (negate $ _cameraRot (_cWorld w))
. (_cameraZoom (_cWorld w) *.*)
. (-.- _cameraCenter (_cWorld w))
{- | Transform coordinates from the map position to screen
coordinates. -}
coordinates.
-}
cartePosToScreen :: Configuration -> World -> Point2 -> Point2
cartePosToScreen cfig w = doWindowScale cfig . doRotate . doZoom . doTranslate
where
doTranslate p = p -.- _carteCenter (_hud (_cWorld w))
doZoom p = _carteZoom (_hud (_cWorld w)) *.* p
doRotate p = rotateV (negate $ _carteRot (_hud (_cWorld w))) p
crToMousePosOffset :: Creature -> World -> (Point2,Float)
crToMousePosOffset cr w = (mouseWorldPos w -.- _crPos cr,0)
{- | The mouse position in world coordinates. -}
doTranslate p = p -.- _carteCenter (_hud (_cWorld w))
doZoom p = _carteZoom (_hud (_cWorld w)) *.* p
doRotate p = rotateV (negate $ _carteRot (_hud (_cWorld w))) p
crToMousePosOffset :: Creature -> World -> (Point2, Float)
crToMousePosOffset cr w = (mouseWorldPos w -.- _crPos cr, 0)
-- | The mouse position in world coordinates.
mouseWorldPos :: World -> Point2
mouseWorldPos w = _cameraCenter (_cWorld w) +.+
(1/_cameraZoom (_cWorld w)) *.* rotateV (_cameraRot (_cWorld w)) (_mousePos w)
{- | The mouse position in map coordinates -}
mouseWorldPos w =
_cameraCenter (_cWorld w)
+.+ (1 / _cameraZoom (_cWorld w)) *.* rotateV (_cameraRot (_cWorld w)) (_mousePos w)
-- | The mouse position in map coordinates
mouseCartePos :: World -> Point2
mouseCartePos w = _carteCenter (_hud (_cWorld w)) +.+
(1/_carteZoom (_hud (_cWorld w))) *.* rotateV (_carteRot (_hud (_cWorld w))) (_mousePos w)
mouseCartePos w =
_carteCenter (_hud (_cWorld w))
+.+ (1 / _carteZoom (_hud (_cWorld w))) *.* rotateV (_carteRot (_hud (_cWorld w))) (_mousePos w)
src/Dodge/Base/Item.hs
-27
View File
@@ -1,27 +0,0 @@
module Dodge.Base.Item
(
) where
--import Dodge.Data
--import Dodge.Base.You
--import LensHelp
--
--import qualified IntMapHelp as IM
--selectedObject :: World -> Maybe (Either FloorItem Button)
--selectedObject w = lookup (_crInvSel ycr) $ zip [n..] $ _closeObjects w
-- where
-- ycr = you w
-- n = length $ _crInv ycr
--
--crItem :: World -> Int -> Item
--crItem w cid = _crInv cr IM.! _crInvSel cr
-- where
-- cr = _creatures w IM.! cid
--
--yourItemRef
-- :: Applicative f
-- => World
-- -> (Item -> f Item)
-- -> World
-- -> f World
--yourItemRef w = creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))
src/Dodge/Base/Wall.hs
+2 -1
View File
@@ -1,5 +1,6 @@
module Dodge.Base.Wall where
import Dodge.Data
import Dodge.Data.Wall
import Geometry
wlIsOpaque :: Wall -> Bool
src/Dodge/Base/Window.hs
+37 -30
View File
@@ -1,54 +1,61 @@
{- | Getting the window size geometry. -}
module Dodge.Base.Window
( halfWidth
, halfHeight
, screenPolygon
, screenPolygonBord
, screenBox
)
where
import Dodge.Data
-- | Getting the window size geometry.
module Dodge.Base.Window (
halfWidth,
halfHeight,
screenPolygon,
screenPolygonBord,
screenBox,
) where
import Dodge.Data.Universe
import Geometry
-- | A box covering the screen in world coordinates
screenPolygon :: Configuration -> World -> [Point2]
screenPolygon cfig w = map (scTran . scRot . scZoom) $ screenBox cfig
-- [tr,tl,bl,br]
where
scRot = rotateV (_cameraRot (_cWorld w))
scZoom p | _cameraZoom (_cWorld w) /= 0 = (1/_cameraZoom (_cWorld w)) *.* p
| otherwise = p
-- [tr,tl,bl,br]
scRot = rotateV (_cameraRot (_cWorld w))
scZoom p
| _cameraZoom (_cWorld w) /= 0 = (1 / _cameraZoom (_cWorld w)) *.* p
| otherwise = p
scTran p = p +.+ _cameraCenter (_cWorld w)
-- tr = scTran $ scRot $ scZoom (V2 ( halfWidth w) ( halfHeight w))
-- tl = scTran $ scRot $ scZoom (V2 (-halfWidth w) ( halfHeight w))
-- br = scTran $ scRot $ scZoom (V2 ( halfWidth w) (-halfHeight w))
-- bl = scTran $ scRot $ scZoom (V2 (-halfWidth w) (-halfHeight w))
-- | A box covering the screen in world coordinates, with a x and y border
screenPolygonBord
:: Float -- ^ X border
-> Float -- ^ Y border
-> Configuration
-> World
-> [Point2]
screenPolygonBord xbord ybord cfig w = [tr,tl,bl,br]
screenPolygonBord ::
-- | X border
Float ->
-- | Y border
Float ->
Configuration ->
World ->
[Point2]
screenPolygonBord xbord ybord cfig w = [tr, tl, bl, br]
where
hw = halfWidth cfig - xbord
hw = halfWidth cfig - xbord
hh = halfHeight cfig - ybord
scZoom p | _cameraZoom (_cWorld w) /= 0 = (1/_cameraZoom (_cWorld w)) *.* p
| otherwise = p
scZoom p
| _cameraZoom (_cWorld w) /= 0 = (1 / _cameraZoom (_cWorld w)) *.* p
| otherwise = p
theTransform = (+.+ _cameraCenter (_cWorld w)) . rotateV (_cameraRot (_cWorld w)) . scZoom
tr = theTransform (V2 hw hh )
tl = theTransform (V2 (-hw) hh )
br = theTransform (V2 hw (-hh))
bl = theTransform (V2 (-hw) (-hh))
tr = theTransform (V2 hw hh)
tl = theTransform (V2 (- hw) hh)
br = theTransform (V2 hw (- hh))
bl = theTransform (V2 (- hw) (- hh))
halfWidth,halfHeight :: Configuration -> Float
halfWidth, halfHeight :: Configuration -> Float
halfWidth w = _windowX w / 2
halfHeight w = _windowY w / 2
-- | A box of the size of the screen in screen centered coordinates
screenBox :: Configuration -> [Point2]
screenBox w = rectNSWE hh (-hh) (-hw) hw
screenBox w = rectNSWE hh (- hh) (- hw) hw
where
hw = halfWidth w
hh = halfHeight w
src/Dodge/Base/You.hs
+2 -3
View File
@@ -1,8 +1,7 @@
module Dodge.Base.You where
import Dodge.Data
--import Picture
import Dodge.Data.World
import qualified IntMapHelp as IM
--import Control.Lens
you :: World -> Creature
you w = _creatures (_cWorld w) IM.! _yourID (_cWorld w)
src/Dodge/Beam.hs
+49 -37
View File
@@ -1,59 +1,71 @@
module Dodge.Beam where
import Dodge.Data
import Data.Maybe
import Dodge.Data.World
import Dodge.Flame
import Dodge.Tesla.Arc
import Dodge.Item.Location
import Dodge.Tesla.Arc
import Geometry
import qualified IntMapHelp as IM
import LensHelp
import Picture
import Data.Maybe
import qualified IntMapHelp as IM
doBeamCombine :: BeamCombineType
-> (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam))
-> World
-> World
doBeamCombine ::
BeamCombineType ->
(Point2, (Point2, Point2, Beam), (Point2, Point2, Beam)) ->
World ->
World
doBeamCombine bct = case bct of
FlameBeamCombine -> flameBeamCombine
LasBeamCombine -> lasBeamCombine
LasBeamCombine -> lasBeamCombine
TeslaBeamCombine -> teslaBeamCombine
SplitBeamCombine -> splitBeamCombine
NoBeamCombine -> const id
flameBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam))
-> World -> World
flameBeamCombine (p,(a,b,_),(x,y,_))
= makeFlame p (2 *.* normalizeV (normalizeV (b-.-a)+.+normalizeV (y-.-x)))
lasBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam))
-> World -> World
lasBeamCombine (p,(a,b,_),(x,y,_))
= cWorld . lasers .:~ lasRayAt yellow 11 1 p (argV (normalizeV (b-.-a)+.+normalizeV (y-.-x)))
splitBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam))
-> World -> World
splitBeamCombine (p,(a,b,_),(x,y,_))
= (cWorld . lasers .:~ lasRayAt yellow 11 1 p (dir+0.5*pi))
. (cWorld . lasers .:~ lasRayAt yellow 11 1 p (dir-0.5*pi))
flameBeamCombine ::
(Point2, (Point2, Point2, Beam), (Point2, Point2, Beam)) ->
World ->
World
flameBeamCombine (p, (a, b, _), (x, y, _)) =
makeFlame p (2 *.* normalizeV (normalizeV (b -.- a) +.+ normalizeV (y -.- x)))
lasBeamCombine ::
(Point2, (Point2, Point2, Beam), (Point2, Point2, Beam)) ->
World ->
World
lasBeamCombine (p, (a, b, _), (x, y, _)) =
cWorld . lasers .:~ lasRayAt yellow 11 1 p (argV (normalizeV (b -.- a) +.+ normalizeV (y -.- x)))
splitBeamCombine ::
(Point2, (Point2, Point2, Beam), (Point2, Point2, Beam)) ->
World ->
World
splitBeamCombine (p, (a, b, _), (x, y, _)) =
(cWorld . lasers .:~ lasRayAt yellow 11 1 p (dir + 0.5 * pi))
. (cWorld . lasers .:~ lasRayAt yellow 11 1 p (dir -0.5 * pi))
where
dir = argV (normalizeV (b-.-a)+.+normalizeV (y-.-x))
dir = argV (normalizeV (b -.- a) +.+ normalizeV (y -.- x))
teslaBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam))
-> World -> World
teslaBeamCombine (p,(a,b,bm),(x,y,_)) w
= w' & pointerToItemLocation (_itemLocations (_cWorld w) IM.! itid) . itParams . subParams ?~ ip
teslaBeamCombine ::
(Point2, (Point2, Point2, Beam), (Point2, Point2, Beam)) ->
World ->
World
teslaBeamCombine (p, (a, b, bm), (x, y, _)) w =
w' & pointerToItemLocation (_itemLocations (_cWorld w) IM.! itid) . itParams . subParams ?~ ip
where
itid = fromJust $ _bmOrigin bm
dir = argV (normalizeV (b-.-a)+.+normalizeV (y-.-x))
(w',ip) = shootTeslaArc' (fromJust . _subParams $ _itParams it) p dir w
dir = argV (normalizeV (b -.- a) +.+ normalizeV (y -.- x))
(w', ip) = shootTeslaArc' (fromJust . _subParams $ _itParams it) p dir w
it = case getItem itid w of
Nothing -> error "tried to get item use teslaBeamCombine that doesn't exist"
Just itm -> itm
lasRayAt :: Color -> Int -> Float -> Point2 -> Float -> LaserStart
lasRayAt col dam phasev pos dir = LaserStart
{ _lpType = DamageLaser dam
, _lpPhaseV = phasev
, _lpPos = pos
, _lpDir = dir
, _lpColor = col
}
lasRayAt col dam phasev pos dir =
LaserStart
{ _lpType = DamageLaser dam
, _lpPhaseV = phasev
, _lpPos = pos
, _lpDir = dir
, _lpColor = col
}
src/Dodge/Beam/Draw.hs
+7 -4
View File
@@ -1,4 +1,5 @@
module Dodge.Beam.Draw where
import Dodge.Data.Beam
import Picture
@@ -8,10 +9,12 @@ drawBeam bd = case bd of
BeamDrawColor _ -> basicDrawBeam
basicDrawBeam :: Beam -> Picture
basicDrawBeam bm = setLayer BloomNoZWrite $ pictures
[ setDepth 19 . color (brightX 0 0.5 col) $ thickLine 20 ps
, setDepth 19.5 . color (brightX 10 1 col) $ thickLine 3 ps
]
basicDrawBeam bm =
setLayer BloomNoZWrite $
pictures
[ setDepth 19 . color (brightX 0 0.5 col) $ thickLine 20 ps
, setDepth 19.5 . color (brightX 10 1 col) $ thickLine 3 ps
]
where
col = _bmColor bm
ps = _bmFirstPoints bm
src/Dodge/Block.hs
+51 -45
View File
@@ -1,42 +1,45 @@
module Dodge.Block where
import Dodge.DrWdWd
import Dodge.Zoning.Wall
import Dodge.Data
import Dodge.Data.MountedObject
import Control.Lens
import Data.Foldable
import qualified Data.Graph.Inductive as FGL
import qualified Data.IntSet as IS
import Data.Maybe
import Dodge.Base.Collide
import Dodge.Material.Sound
import Dodge.Block.Debris
import Dodge.Data.World
import Dodge.DrWdWd
import Dodge.LightSource
import Dodge.Wall.Zone
import Dodge.WorldEvent.Sound
import Dodge.Material.Sound
import Dodge.Wall.Delete
import Dodge.Wall.Dust
import RandomHelp
import Dodge.Wall.Zone
import Dodge.WorldEvent.Sound
import Dodge.Zoning.Wall
import Geometry
--import Geometry.ConvexPoly
import Data.Foldable
import Data.Function
import Data.Maybe
import qualified Data.IntSet as IS
import qualified IntMapHelp as IM
import Control.Lens
import qualified Data.Graph.Inductive as FGL
import RandomHelp
splinterBlock :: Block -> World -> World
splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
& originsIDsAt [MaterialSound bm 0,MaterialSound bm 1,MaterialSound bm 2]
(weakenMatS bm) (_blPos bl)
splinterBlock bl w =
foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl)
& originsIDsAt
[MaterialSound bm 0, MaterialSound bm 1, MaterialSound bm 2]
(weakenMatS bm)
(_blPos bl)
where
bm = fromMaybe Stone $ do
wlids <- w ^? cWorld . blocks . ix (_blID bl) . blWallIDs
(wlid,_) <- IS.minView wlids
(wlid, _) <- IS.minView wlids
w ^? cWorld . walls . ix wlid . wlMaterial
unshadowBlock :: Int -> World -> World
unshadowBlock wlid w = case w ^? cWorld . walls . ix wlid of
Just wl -> w
& cWorld . walls . ix wlid . wlUnshadowed .~ True
& insertWallInZones (wl & wlUnshadowed .~ True)
Just wl ->
w
& cWorld . walls . ix wlid . wlUnshadowed .~ True
& insertWallInZones (wl & wlUnshadowed .~ True)
Nothing -> w
checkBlockHP :: Block -> World -> World
@@ -45,14 +48,15 @@ checkBlockHP bl
| otherwise = id
destroyBlock :: Block -> World -> World
destroyBlock bl w = w
& flip (foldr unshadowBlock) (_blShadows bl)
& makeBlockDebris bl
& deleteWallIDs wlids
& maybeClearPaths (_blObstructs bl) -- must happen after the walls are deleted
& cWorld . blocks %~ IM.delete (_blID bl)
-- & matDesSound (_blMaterial bl) pos
& flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
destroyBlock bl w =
w
& flip (foldr unshadowBlock) (_blShadows bl)
& makeBlockDebris bl
& deleteWallIDs wlids
& maybeClearPaths (_blObstructs bl) -- must happen after the walls are deleted
& cWorld . blocks %~ IM.delete (_blID bl)
-- & matDesSound (_blMaterial bl) pos
& flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
where
wlids = _blWallIDs bl
awl = _walls (_cWorld w) IM.! IS.findMin wlids
@@ -60,23 +64,24 @@ destroyBlock bl w = w
ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
-- this does not handle eg doors blocking the path as well
maybeClearPaths :: [(Int,Int,PathEdge)] -> World -> World
maybeClearPaths :: [(Int, Int, PathEdge)] -> World -> World
maybeClearPaths ps w = foldl' maybeClearPath w ps
maybeClearPath :: World -> (Int,Int,PathEdge) -> World
maybeClearPath w (x,y,pe)
| not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w
= w
| otherwise = w & cWorld . pathGraph %~ FGL.insEdge (x,y,pe & peObstacles .~ mempty) . FGL.delEdge (x,y)
maybeClearPath :: World -> (Int, Int, PathEdge) -> World
maybeClearPath w (x, y, pe)
| not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w =
w
| otherwise = w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles .~ mempty) . FGL.delEdge (x, y)
destroyDoor :: Door -> World -> World
destroyDoor dr w = w
& doDrWdWd (_drDeath dr) dr
& deleteWallIDs wlids
& cWorld . doors %~ IM.delete (_drID dr)
& flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
& stopPushing (_drPushes dr)
& destroyMounts (_drMounts dr)
destroyDoor dr w =
w
& doDrWdWd (_drDeath dr) dr
& deleteWallIDs wlids
& cWorld . doors %~ IM.delete (_drID dr)
& flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
& stopPushing (_drPushes dr)
& destroyMounts (_drMounts dr)
where
wlids = _drWallIDs dr
awl = _walls (_cWorld w) IM.! IS.findMin wlids
@@ -95,5 +100,6 @@ stopPushing :: Maybe Int -> World -> World
stopPushing mdrid w = fromMaybe w $ do
drid <- mdrid
dr <- w ^? cWorld . doors . ix drid
return $ w & cWorld . doors . ix drid . drMech .~ DrWdId
& stopPushing (_drPushes dr)
return $
w & cWorld . doors . ix drid . drMech .~ DrWdId
& stopPushing (_drPushes dr)
src/Dodge/Block/Debris.hs
+130 -104
View File
@@ -1,171 +1,197 @@
module Dodge.Block.Debris where
import Dodge.Material.Sound
import Dodge.WorldEvent.Sound
import Dodge.Base
import Dodge.Data
import Shape
import Geometry
import Color
import LensHelp
import RandomHelp
import Grid
import qualified Quaternion as Q
import Color
import Data.Foldable
import qualified Data.IntSet as IS
import Data.Maybe
import Data.Foldable
import Dodge.Base
import Dodge.Data.World
import Dodge.Material.Sound
import Dodge.WorldEvent.Sound
import Geometry
import Grid
import LensHelp
import qualified Quaternion as Q
import RandomHelp
import Shape
makeDoorDebris :: Door -> World -> World
makeDoorDebris dr w = w & makeDebris mt col p
where
p = uncurry midPoint (_drPos dr)
(mt,col) = fromMaybe (Stone,greyN 0.5) $ do
(mt, col) = fromMaybe (Stone, greyN 0.5) $ do
wlids <- w ^? cWorld . doors . ix (_drID dr) . drWallIDs
(wlid,_) <- IS.minView wlids
(wlid, _) <- IS.minView wlids
wl <- w ^? cWorld . walls . ix wlid
return (_wlMaterial wl,_wlColor wl)
return (_wlMaterial wl, _wlColor wl)
makeBlockDebris :: Block -> World -> World
--makeBlockDebris bl w = w & makeDebris mt col (_blPos bl)
makeBlockDebris bl w = foldr (makeDebris mt col) w ps
where
dsize = debrisSize mt
ps = gridInPolygon dsize $ shrinkPolyOnEdges dsize $ reverse (_blFootprint bl)
(mt,col) = fromMaybe (Stone,greyN 0.5) $ do
(mt, col) = fromMaybe (Stone, greyN 0.5) $ do
wlids <- w ^? cWorld . blocks . ix (_blID bl) . blWallIDs
(wlid,_) <- IS.minView wlids
(wlid, _) <- IS.minView wlids
wl <- w ^? cWorld . walls . ix wlid
return (_wlMaterial wl,_wlColor wl)
return (_wlMaterial wl, _wlColor wl)
makeDebrisToHeight :: Float -> Material -> Color -> Point2 -> World -> World
makeDebrisToHeight = makeDebrisDirectedHeight 1 2 (2*pi) 0
makeDebrisToHeight = makeDebrisDirectedHeight 1 2 (2 * pi) 0
makeDebris :: Material -> Color -> Point2 -> World -> World
makeDebris = makeDebrisDirected 1 2 (2*pi) 0
makeDebris = makeDebrisDirected 1 2 (2 * pi) 0
makeDebrisDirectedHeight :: Float -> Float -> Float -> Float -> Float -> Material
-> Color -> Point2 -> World -> World
makeDebrisDirectedHeight mindist maxdist arcrad dir maxh bm col p w = w
makeDebrisDirectedHeight ::
Float ->
Float ->
Float ->
Float ->
Float ->
Material ->
Color ->
Point2 ->
World ->
World
makeDebrisDirectedHeight mindist maxdist arcrad dir maxh bm col p w =
w
& flip (foldl' (flip $ plNew (cWorld . props) prID)) thedebris
& randGen .~ newg
& originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p
& originsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
where
dsize = debrisSize bm
(thedebris,newg) = mapM f [10,10 + dsize ..maxh+5] & runState $ _randGen w
(thedebris, newg) = mapM f [10, 10 + dsize .. maxh + 5] & runState $ _randGen w
f h = do
v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad
v <- rotateV (dir - arcrad / 2) <$> randInArcStrip mindist maxdist arcrad
q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
spinspeed <- randomR (-0.2,-0.1) & state
spinspeed <- randomR (-0.2, -0.1) & state
basedebris <- baseDebris bm
return $ basedebris
& prColor .~ col
& prPos .~ p
& prVel .~ v
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
& prQuat .~ q
& prVelZ .~ 0
& prPosZ .~ h
return $
basedebris
& prColor .~ col
& prPos .~ p
& prVel .~ v
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
& prQuat .~ q
& prVelZ .~ 0
& prPosZ .~ h
makeDebrisDirected :: Float
-> Float
-> Float
-> Float
-> Material
-> Color
-> Point2
-> World -> World
makeDebrisDirected mindist maxdist arcrad dir bm col p w = w
makeDebrisDirected ::
Float ->
Float ->
Float ->
Float ->
Material ->
Color ->
Point2 ->
World ->
World
makeDebrisDirected mindist maxdist arcrad dir bm col p w =
w
& flip (foldl' (flip $ plNew (cWorld . props) prID)) thedebris
& randGen .~ newg
& originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p
& originsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p
where
(thedebris,newg) = mapM f [35,55..95] & runState $ _randGen w
(thedebris, newg) = mapM f [35, 55 .. 95] & runState $ _randGen w
f h = do
v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad
v <- rotateV (dir - arcrad / 2) <$> randInArcStrip mindist maxdist arcrad
q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
spinspeed <- randomR (-0.2,-0.1) & state
spinspeed <- randomR (-0.2, -0.1) & state
basedebris <- baseDebris bm
return $ basedebris
& prColor .~ col
& prPos .~ p
& prVel .~ v
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
& prQuat .~ q
& prVelZ .~ 0
& prPosZ .~ h
return $
basedebris
& prColor .~ col
& prPos .~ p
& prVel .~ v
& prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed
& prQuat .~ q
& prVelZ .~ 0
& prPosZ .~ h
debrisSize :: Material -> Float
debrisSize mt = case mt of
Stone -> 20
Glass -> 10
Stone -> 20
Glass -> 10
Crystal -> 10
Dirt -> 20
Wood -> 10
Metal -> 10
Dirt -> 20
Wood -> 10
Metal -> 10
Electronics -> 10
Flesh -> 10
baseDebris :: Material -> State StdGen Prop
baseDebris mt = case mt of
Stone -> return stoneDebris
Glass -> return glassDebris
Stone -> return stoneDebris
Glass -> return glassDebris
Crystal -> return crystalDebris
Dirt -> return dirtDebris
Wood -> return stoneDebris
Metal -> do
Dirt -> return dirtDebris
Wood -> return stoneDebris
Metal -> do
sh <- jaggedShape
return $ metalDebris
& prDraw .~ PropDrawMovingShapeCol sh
return $
metalDebris
& prDraw .~ PropDrawMovingShapeCol sh
Electronics -> baseDebris Metal
Flesh -> baseDebris Dirt <&> prColor .~ red
Flesh -> baseDebris Dirt <&> prColor .~ red
stoneDebris :: Prop
stoneDebris = PropZ
{_prPos = 0
,_prStartPos = 0
,_prVel = 0
,_prDraw = PropDrawMovingShapeCol (cubeShape 4)
,_prID = 0
,_prUpdate = PropFallSmallBounceDamage
,_prPosZ = 10
,_prVelZ = 5
,_prTimer = 20
,_prQuat = Q.axisAngle (V3 1 0 0) 0
,_prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
,_prColor = greyN 0.5
}
stoneDebris =
PropZ
{ _prPos = 0
, _prStartPos = 0
, _prVel = 0
, _prDraw = PropDrawMovingShapeCol (cubeShape 4)
, _prID = 0
, _prUpdate = PropFallSmallBounceDamage
, _prPosZ = 10
, _prVelZ = 5
, _prTimer = 20
, _prQuat = Q.axisAngle (V3 1 0 0) 0
, _prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
, _prColor = greyN 0.5
}
dirtDebris :: Prop
dirtDebris = stoneDebris
& prColor .~ dirtColor
& prUpdate .~ PropFallSmallBounce
dirtDebris =
stoneDebris
& prColor .~ dirtColor
& prUpdate .~ PropFallSmallBounce
dirtColor :: Color
dirtColor = V4 (150/256) ( 75/256) 0 ( 250/256)
dirtColor = V4 (150 / 256) (75 / 256) 0 (250 / 256)
metalDebris :: Prop
metalDebris = stoneDebris
& prDraw .~ PropDrawMovingShapeCol (shardShape 4)
& prUpdate .~ PropFallSmallBounceDamage
metalDebris =
stoneDebris
& prDraw .~ PropDrawMovingShapeCol (shardShape 4)
& prUpdate .~ PropFallSmallBounceDamage
glassDebris :: Prop
glassDebris = stoneDebris
& prDraw .~ PropDrawMovingShapeCol (shardShape 4)
& prUpdate .~ PropFallSmallBounce
& prColor .~ withAlpha 0.5 cyan
glassDebris =
stoneDebris
& prDraw .~ PropDrawMovingShapeCol (shardShape 4)
& prUpdate .~ PropFallSmallBounce
& prColor .~ withAlpha 0.5 cyan
crystalDebris :: Prop
crystalDebris = glassDebris
& prColor .~ withAlpha 0.5 aquamarine
crystalDebris =
glassDebris
& prColor .~ withAlpha 0.5 aquamarine
shardShape :: Float -> Shape
shardShape size = translateSHz (-size) $ upperPrismPoly size
[V2 size 0
,V2 (-size) 1
,V2 (-size) (-1)
]
shardShape size =
translateSHz (- size) $
upperPrismPoly
size
[ V2 size 0
, V2 (- size) 1
, V2 (- size) (-1)
]
jaggedShape :: State StdGen Shape
jaggedShape = do
s <- randomR (4,10) & state
s <- randomR (4, 10) & state
return $ shardShape s
cubeShape :: Float -> Shape
cubeShape size = translateSHz (-size) $ upperPrismPoly (2*size) $ square size
cubeShape size = translateSHz (- size) $ upperPrismPoly (2 * size) $ square size
src/Dodge/Bullet.hs
+1 -1
View File
@@ -7,7 +7,7 @@ import Data.Maybe
import Dodge.Base.Coordinate
import Dodge.Creature.HandPos
import Dodge.Creature.Test
import Dodge.Data
import Dodge.Data.World
import Dodge.EnergyBall
import Dodge.MagnetBuBu
import Dodge.Movement.Turn
src/Dodge/Bullet/Draw.hs
+11 -8
View File
@@ -1,11 +1,14 @@
module Dodge.Bullet.Draw
( drawBul
) where
module Dodge.Bullet.Draw (
drawBul,
) where
import Dodge.Data.Bullet
import Picture
import Linear
import Picture
drawBul :: Bullet -> Picture
drawBul pt = setLayer BloomNoZWrite
. setDepth 20
. color (V4 200 200 200 2)
$ thickLine (_buWidth pt) [_buOldPos pt, _buPos pt]
drawBul pt =
setLayer BloomNoZWrite
. setDepth 20
. color (V4 200 200 200 2)
$ thickLine (_buWidth pt) [_buOldPos pt, _buPos pt]
src/Dodge/Button/Draw.hs
+17 -13
View File
@@ -1,9 +1,10 @@
module Dodge.Button.Draw where
import Color
import Dodge.Data.Button
import Geometry
import Color
import ShapePicture
import Shape
import ShapePicture
drawButton :: ButtonDraw -> Button -> SPic
drawButton bd = case bd of
@@ -13,16 +14,19 @@ drawButton bd = case bd of
drawSwitch :: Color -> Color -> Button -> SPic
drawSwitch col1 col2 bt
| _btState bt == BtOff
= flick $ pi/4
| otherwise = flick (negate (pi/4))
| _btState bt == BtOff =
flick $ pi / 4
| otherwise = flick (negate (pi / 4))
where
flick a = ( mconcat
[ colorSH col1 . upperPrismPoly 20 $ reverse $ rectNSWE (-2) (-5) (-10) 10
, colorSH col2 . translateSH (V3 0 (-2) 20) . rotateSH a . upperPrismPoly 2 $ reverse
$ rectNSWE 10 0 (-2) 2
]
, mempty)
flick a =
( mconcat
[ colorSH col1 . upperPrismPoly 20 $ reverse $ rectNSWE (-2) (-5) (-10) 10
, colorSH col2 . translateSH (V3 0 (-2) 20) . rotateSH a . upperPrismPoly 2 $
reverse $
rectNSWE 10 0 (-2) 2
]
, mempty
)
defaultDrawButton :: Color -> Button -> SPic
defaultDrawButton col bt =
@@ -31,6 +35,6 @@ defaultDrawButton col bt =
)
where
buttonGeometry
| _btState bt == BtOff = reverse $ rectNSWE 10 (-1) (-width) width
| otherwise = reverse $ rectNSWE 2 (-1) (-width) width
| _btState bt == BtOff = reverse $ rectNSWE 10 (-1) (- width) width
| otherwise = reverse $ rectNSWE 2 (-1) (- width) width
width = 8
src/Dodge/Button/Event.hs
+17 -13
View File
@@ -1,31 +1,35 @@
module Dodge.Button.Event where
import Dodge.Data
import Dodge.SoundLogic
import Dodge.WorldEffect
import Control.Lens
import Dodge.Data.World
import Dodge.SoundLogic
import Dodge.WorldEffect
doButtonEvent :: ButtonEvent -> Button -> World -> World
doButtonEvent be = case be of
ButtonDoNothing -> const id
ButtonPress newstate newevent thesound f -> \b -> doWdWd f
. set (cWorld . buttons . ix (_btID b) . btState) newstate
. set (cWorld . buttons . ix (_btID b) . btEvent) newevent
. soundStart (LeverSound 0) (_btPos b) thesound Nothing
ButtonPress newstate newevent thesound f -> \b ->
doWdWd f
. set (cWorld . buttons . ix (_btID b) . btState) newstate
. set (cWorld . buttons . ix (_btID b) . btEvent) newevent
. soundStart (LeverSound 0) (_btPos b) thesound Nothing
--ButtonSwitch onstate onevent onsound oneff offstate offevent offsound offeff -> undefined
ButtonSimpleSwith oneff offeff -> flipSwitch oneff offeff
ButtonAccessTerminal -> accessTerminal . _btTermMID
flipSwitch :: WdWd -> WdWd -> Button -> World -> World
flipSwitch oneff offeff bt
| _btState bt == BtOff = doWdWd oneff . dosound
. over (cWorld . buttons . ix (_btID bt)) turnon
| otherwise = doWdWd offeff . dosound
. over (cWorld . buttons . ix (_btID bt)) turnoff
| _btState bt == BtOff =
doWdWd oneff . dosound
. over (cWorld . buttons . ix (_btID bt)) turnon
| otherwise =
doWdWd offeff . dosound
. over (cWorld . buttons . ix (_btID bt)) turnoff
where
turnon = (btState .~ BtOn ) . (btText .~ "SWITCH\\")
turnoff = (btState .~ BtOff) . (btText .~ "SWITCH/")
turnon = (btState .~ BtOn) . (btText .~ "SWITCH\\")
turnoff = (btState .~ BtOff) . (btText .~ "SWITCH/")
dosound = soundFromGeneral (LeverSound 0) (const $ _btPos bt) click1S Nothing
-- switchEffect b = case _btState b of
-- BtOff -> effOn . (buttons . ix (_btID b) %~ turnOn )
-- BtOn -> effOff . (buttons . ix (_btID b) %~ turnOff)
src/Dodge/ChainEffect.hs
+1 -1
View File
@@ -1,5 +1,5 @@
module Dodge.ChainEffect where
import Dodge.Data
import Dodge.Data.World
type ChainEffect =
(Item -> Creature -> World -> World)
src/Dodge/Cleat.hs
+1 -1
View File
@@ -6,7 +6,7 @@ module Dodge.Cleat
, rToOnward
, cleatLabel
) where
import Dodge.Data
import Dodge.Data.GenWorld
import Dodge.Tree.Compose
import Data.Tree
src/Dodge/Clock.hs
+1 -1
View File
@@ -1,7 +1,7 @@
module Dodge.Clock
( clockCycle
) where
import Dodge.Data
import Dodge.Data.World
import qualified Data.Vector as V
clockCycle :: Int -> V.Vector a -> World -> a
src/Dodge/Combine.hs
+55 -55
View File
@@ -1,85 +1,85 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Combine
( combinePoss
, combineSizes
, combineItemListYou
, combineListInfo
, toggleCombineInv
, enterCombineInv
) where
import Dodge.Combine.Trie
module Dodge.Combine (
combinePoss,
combineSizes,
combineItemListYou,
combineListInfo,
toggleCombineInv,
enterCombineInv,
) where
import Control.Lens
import Control.Monad
import Data.Bifunctor
import Data.List (scanl', sortOn)
import Data.Map.Merge.Strict
import qualified Data.Map.Strict as M
import Data.Maybe
import Dodge.Base.You
import Dodge.Data
import Dodge.Item.Amount
import Dodge.Combine.Trie
import Dodge.Data.World
import Dodge.Inventory.ItemSpace
--import Dodge.Combine.Module
import Dodge.Item.Amount
import Dodge.Module
--import Dodge.Combine.Data
--import Multiset
import qualified IntMapHelp as IM
import SimpleTrie
import Data.Map.Merge.Strict
import Control.Monad
import Control.Lens
import Data.Bifunctor
import qualified IntMapHelp as IM
--import qualified Data.IntSet as IS
import qualified Data.Map.Strict as M
--import Data.Map.Merge.Strict
import Data.Maybe
import Data.List (scanl',sortOn)
invertInventory :: IM.IntMap Item -> [(ItemBaseType, ItAmount, Int)]
invertInventory =
IM.foldrWithKey
(\k it -> ((_iyBase $ _itType it, itStackAmount it, k) :))
[]
invertInventory :: IM.IntMap Item -> [(ItemBaseType,ItAmount,Int)]
invertInventory = IM.foldrWithKey
(\k it -> ((_iyBase $ _itType it, itStackAmount it,k) :) )
[]
splitItAmounts :: [(ItemBaseType,ItAmount,Int)] -> [((ItAmount,ItemBaseType),(ItAmount,Int))]
splitItAmounts :: [(ItemBaseType, ItAmount, Int)] -> [((ItAmount, ItemBaseType), (ItAmount, Int))]
splitItAmounts = concatMap f
where
f (x,n,y) = [((i,x),(i,y)) | i <- [1..n]]
f (x, n, y) = [((i, x), (i, y)) | i <- [1 .. n]]
lookupItems :: IM.IntMap Item -> [([(ItAmount,Int)],Item)]
lookupItems :: IM.IntMap Item -> [([(ItAmount, Int)], Item)]
lookupItems = flip multiLookupTrieI combinationsTrie . sortOn fst . splitItAmounts . invertInventory
combineItemListYouX :: World -> [([Int],Item)]
combineItemListYouX :: World -> [([Int], Item)]
combineItemListYouX = map (first $ concatMap g) . lookupItems . yourInv
where
g (amount,i) = replicate (_getItAmount amount) i
g (amount, i) = replicate (_getItAmount amount) i
combineListInfo :: World -> [([Int],([String],Item))]
combineListInfo :: World -> [([Int], ([String], Item))]
combineListInfo w = filter (f . snd . snd) . map (cmm inv) $ combineItemListYouX w
where
inv = yourInv w
f itm = _itType itm `notElem` fmap _itType inv
combineItemListYou :: World -> [([Int],Item)]
combineItemListYou :: World -> [([Int], Item)]
combineItemListYou = map (second snd) . combineListInfo
cmm :: IM.IntMap Item -> ([Int],Item) -> ([Int],([String],Item))
cmm inv (is,itm) = (is,itm & itType . iyModules %%~ flip combineModuleMaps mms)
cmm :: IM.IntMap Item -> ([Int], Item) -> ([Int], ([String], Item))
cmm inv (is, itm) = (is, itm & itType . iyModules %%~ flip combineModuleMaps mms)
where
mms = map (_iyModules . _itType . (inv IM.!)) is
combineModuleMaps :: M.Map ModuleSlot ItemModuleType
-> [M.Map ModuleSlot ItemModuleType]
-> ([String],M.Map ModuleSlot ItemModuleType)
combineModuleMaps ::
M.Map ModuleSlot ItemModuleType ->
[M.Map ModuleSlot ItemModuleType] ->
([String], M.Map ModuleSlot ItemModuleType)
combineModuleMaps = foldM combineTwoModuleMaps
combineTwoModuleMaps :: M.Map ModuleSlot ItemModuleType
-> M.Map ModuleSlot ItemModuleType
-> ([String],M.Map ModuleSlot ItemModuleType)
combineTwoModuleMaps = mergeA
preserveMissing
(filterAMissing f)
(zipWithAMatched g)
combineTwoModuleMaps ::
M.Map ModuleSlot ItemModuleType ->
M.Map ModuleSlot ItemModuleType ->
([String], M.Map ModuleSlot ItemModuleType)
combineTwoModuleMaps =
mergeA
preserveMissing
(filterAMissing f)
(zipWithAMatched g)
where
f _ EMPTYMODULE = ([],False)
f _ md = ([rm "REMOVES" md],False)
g _ EMPTYMODULE md = ([],md)
g _ md EMPTYMODULE = ([],md)
g _ md2 md1 = ([rm "REPLACES" md1 ++ rm " WITH" md2],md2)
rm str md = str ++ " "++fullModuleName md
f _ EMPTYMODULE = ([], False)
f _ md = ([rm "REMOVES" md], False)
g _ EMPTYMODULE md = ([], md)
g _ md EMPTYMODULE = ([], md)
g _ md2 md1 = ([rm "REPLACES" md1 ++ rm " WITH" md2], md2)
rm str md = str ++ " " ++ fullModuleName md
-- g above could be a monoid of some description...
fullModuleName :: ItemModuleType -> String
@@ -87,7 +87,7 @@ fullModuleName = fromMaybe "EMPTYMODULE" . moduleName
toggleCombineInv :: World -> World
toggleCombineInv w = case _hudElement (_hud (_cWorld w)) of
DisplayInventory CombineInventory {} -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory
DisplayInventory CombineInventory{} -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory
_ -> w & enterCombineInv
enterCombineInv :: World -> World
src/Dodge/Combine/Combinations.hs
+11 -32
View File
@@ -18,29 +18,21 @@ itemCombinations =
, po [cr CAN, cr HARDWARE] bangCone
, po [HELD BANGCONE, cr PLANK] blunderbuss
, po [HELD BLUNDERBUSS, cr DRUM] (grapeCannon 1)
, -- , po [BANGCONE,PUMP,HARDWARE] $ grenadeLauncher 1
-- , po [GRENADELAUNCHER 1,MOTOR,DRUM] $ grenadeLauncher 2
-- , po [cr PIPE, cr HARDWARE] (volleyGun 1)
po [HELD (BANGSTICK 1), cr PLANK] rifle
, po [HELD (BANGSTICK 1), cr PLANK] rifle
, po [HELD (BANGSTICK 1), HELD (BANGSTICK 1), HELD (BANGSTICK 1)] (volleyGun 3)
, po [HELD RIFLE, cr TIN] repeater
, po [HELD REPEATER, cr SPRING] autoRifle
, po [HELD REPEATER, cr CAN] burstRifle
-- , po [BURSTRIFLE,cr SPRING,cr HARDWARE] fastBurstRifle
-- , po [FASTBURSTRIFLE,cr SPRING,cr HARDWARE] completeBurstRifle
]
++ [ po [cr MOTOR, HELD (VOLLEYGUN i)] $ miniGunX i | i <- [3 .. 10]
]
++
-- , po [BANGSTICK 1,cr TUBE] elephantGun
[ po [HELD AMR, cr PIPE] sniperRifle
, po [HELD RIFLE, cr PIPE] amr
, po [HELD AMR, cr SPRING] autoAmr
, po [HELD AMR, cr MOTOR] machineGun
, p [p 2 $ cr TUBE, o $ cr HARDWARE] launcher
, p [p 2 $ cr TUBE, o $ HELD LAUNCHER] (launcherX 2)
]
++ [ po [HELD AMR, cr PIPE] sniperRifle
, po [HELD RIFLE, cr PIPE] amr
, po [HELD AMR, cr SPRING] autoAmr
, po [HELD AMR, cr MOTOR] machineGun
, p [p 2 $ cr TUBE, o $ cr HARDWARE] launcher
, p [p 2 $ cr TUBE, o $ HELD LAUNCHER] (launcherX 2)
]
++ [p [p 2 $ cr TUBE, o $ HELD (LAUNCHERX i)] (launcherX (i + 1)) | i <- [2 .. 9]]
++ [ po [cr LIGHTER, cr PUMP, cr CAN] flameSpitter
, po [HELD FLAMESPITTER, cr CAN, cr PUMP] blowTorch
@@ -48,12 +40,8 @@ itemCombinations =
, po [HELD FLAMETHROWER, cr DRUM] flameWall
, po [HELD FLAMETHROWER, cr PUMP] flameTorrent
, p [o $ cr PRISM, o $ cr TRANSFORMER, o $ cr PIPE] lasGun
, -- , p [o LASGUN,o $ cr PRISM] lasSway
-- , p [o LASGUN,o $ cr HARDWARE] lasSwing
-- , p [o LASGUN,o PIPE] lasGunPulse
po [HELD LASGUN, HELD LASGUN, cr HARDWARE] dualBeam
, -- , p [o LASGUN,o $ cr PIPE, o $ cr PRISM] lasWidePulse
po [HELD LASGUN, cr TRANSFORMER] (lasWide 2)
, po [HELD LASGUN, HELD LASGUN, cr HARDWARE] dualBeam
, po [HELD LASGUN, cr TRANSFORMER] (lasWide 2)
, po [HELD LASGUN, HELD LASGUN, HELD LASGUN, cr HARDWARE] lasCircle
, p [o $ cr TRANSFORMER, p 2 $ cr CAN] sparkGun
, p [o (HELD SPARKGUN), p 2 $ cr PIPE] teslaGun
@@ -77,7 +65,6 @@ itemCombinations =
, po [cr TRANSFORMER, cr BATTERY, cr MICROCHIP] (makeTypeCraft STATICMODULE)
]
++ map (\i -> po [HELD (LASWIDE i), cr TRANSFORMER] $ lasWide (i + 1)) [2 .. 9]
-- ++ map (\i -> po [LASGUNWIDE i,cr HARDWARE] $ lasFocus i) [2..10]
++ map (\i -> po [cr PIPE, HELD (BANGSTICK i)] $ bangStick (i + 1)) [1 .. 8]
++ map (\i -> po [hd (REVOLVERX i), cr CAN] $ revolverX (i + 1)) [1 .. 5]
++ map (\i -> po [hd (VOLLEYGUN i), HELD (BANGSTICK 1)] $ volleyGun (i + 1)) [3 .. 5]
@@ -107,7 +94,6 @@ moduleCombinations =
[ repeater
, autoRifle
, burstRifle
-- ,fastBurstRifle
]
,
[ amod [cr DRUM, cr HARDWARE] DRUMMAG
@@ -214,15 +200,10 @@ batteryGuns =
[ teslaGun
, sparkGun
, lasGun
-- , lasSway
-- , lasSwing
]
++ [ lasWide i | i <- [2 .. 10]
]
-- ++
-- [ lasFocus i | i <- [1..10]]
teleportableWeapons :: [Item]
teleportableWeapons = bulletWeapons ++ batteryGuns ++ homingLaunchers
@@ -242,9 +223,7 @@ bulletWeapons =
, repeater
, autoRifle
, burstRifle
, -- ,fastBurstRifle
-- ,completeBurstRifle
bangCone
, bangCone
, blunderbuss
, machineGun
, elephantGun
src/Dodge/Combine/Graph.hs
+1 -1
View File
@@ -1,7 +1,7 @@
--{-# LANGUAGE TypeSynonymInstances #-}
--{-# LANGUAGE FlexibleInstances #-}
module Dodge.Combine.Graph where
import Dodge.Data hiding (East,West,North,South)
import Dodge.Data.Item
import Dodge.Combine.Combinations
import LensHelp
import GraphHelp
src/Dodge/Combine/Module.hs
+38 -31
View File
@@ -1,43 +1,50 @@
module Dodge.Combine.Module where
import Dodge.Data
import Dodge.Item.Targeting
import Dodge.Data.Beam
import Dodge.Data.Item
--import Dodge.Item.Weapon.ExtraEffect
import Dodge.Tesla
import Dodge.Item.Weapon.ExtraEffect
import LensHelp
import Geometry
import LensHelp
moduleModification :: ItemModuleType -> Item -> Item
moduleModification imt = case imt of
EMPTYMODULE -> id
DRUMMAG -> itUse . heldConsumption . laMax .~ 45
BELTMAG -> itUse . heldConsumption . laMax .~ 150
MAGNETMAG -> itUse . useDelay . rateMax .~ 4
INCENDBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall IncBall
BOUNCEBUL -> itUse . heldConsumption . laAmmoType . amBullet . buEffect .~ BounceBullet
PENBUL -> itUse . heldConsumption . laAmmoType . amBullet . buEffect .~ PenetrateBullet
STATICBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall TeslaBall
CONCUSBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall ConcBall
TARGCR -> itTargeting .~ targetRBCreature
TARGLAS -> itTargeting .~ targetLaser
TARGPOS -> itTargeting .~ targetRBPress
MAGNETTRAJ -> (itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ MagnetTrajectory 0)
. (itUse . heldConsumption . laAmmoType . amBullet . buVel .~ V2 10 0)
FLECHETRAJ -> itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ FlechetteTrajectory 0
BEZIERTRAJ -> itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ BezierTrajectory 0 0 0
INCENDLAS -> itParams . lasBeam .~ BeamCombine FlameBeamCombine
SPLITLAS -> itParams . lasBeam .~ BeamCombine SplitBeamCombine
STATICLAS -> (itParams . lasBeam .~ BeamCombine TeslaBeamCombine)
. (itParams . subParams ?~ teslaParams)
WEPTELE -> makeDirectedTele
LAUNCHHOME -> itUse . heldConsumption . laAmmoType . amPjCreation .~ CreateTrackingShell
DRUMMAG -> itUse . heldConsumption . laMax .~ 45
BELTMAG -> itUse . heldConsumption . laMax .~ 150
MAGNETMAG -> itUse . heldDelay . rateMax .~ 4
INCENDBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall IncBall
BOUNCEBUL -> itUse . heldConsumption . laAmmoType . amBullet . buEffect .~ BounceBullet
PENBUL -> itUse . heldConsumption . laAmmoType . amBullet . buEffect .~ PenetrateBullet
STATICBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall TeslaBall
CONCUSBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall ConcBall
TARGCR -> itTargeting .~ targetRBCreature
TARGLAS -> itTargeting .~ targetLaser
TARGPOS -> itTargeting .~ targetRBPress
MAGNETTRAJ ->
(itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ MagnetTrajectory 0)
. (itUse . heldConsumption . laAmmoType . amBullet . buVel .~ V2 10 0)
FLECHETRAJ -> itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ FlechetteTrajectory 0
BEZIERTRAJ -> itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ BezierTrajectory 0 0 0
INCENDLAS -> itParams . lasBeam .~ BeamCombine FlameBeamCombine
SPLITLAS -> itParams . lasBeam .~ BeamCombine SplitBeamCombine
STATICLAS ->
(itParams . lasBeam .~ BeamCombine TeslaBeamCombine)
. (itParams . subParams ?~ teslaParams)
WEPTELE -> makeDirectedTele
LAUNCHHOME -> itUse . heldConsumption . laAmmoType . amPjCreation .~ CreateTrackingShell
EXTRABATTERY -> itUse . heldConsumption . laMax +~ 1000
ATTACHTORCH -> id
ATTACHTORCH -> id
where
makeDirectedTele it = it
& itTargeting .~ targetRBPress
& itUse . useMods %~ ModWithDirectedTeleport -- .:~ withPosDirWallCheck directedTelPos
-- for the camera: the simplest option is to remove all zoom/offset
& itUse . useAim . aimZoom . itZoomFac .~ 1
& itUse . useAim . aimRange .~ 0
makeDirectedTele it =
it
& itTargeting .~ targetRBPress
& itUse . heldMods %~ ModWithDirectedTeleport -- .:~ withPosDirWallCheck directedTelPos
-- for the camera: the simplest option is to remove all zoom/offset
& itUse . heldAim . aimZoom . itZoomFac .~ 1
& itUse . heldAim . aimRange .~ 0
-- a better option would be to involve a "scope" centered on the firing
-- position
-- directedTelPos it cr w = (p,a)
src/Dodge/Combine/Trie.hs
+10 -13
View File
@@ -1,19 +1,16 @@
module Dodge.Combine.Trie where
import Dodge.Combine.Combinations
import Dodge.Data
--import Dodge.Combine.Module
--import Dodge.Combine.Data
--import Multiset
import SimpleTrie
import Data.Bifunctor
--import qualified Data.IntSet as IS
--import Data.Map.Merge.Strict
import Data.List (sort)
import Dodge.Combine.Combinations
import Dodge.Data.Item
import SimpleTrie
import Data.Foldable
combinationsTrie :: Trie (ItAmount,ItemBaseType) Item
combinationsTrie :: Trie (ItAmount, ItemBaseType) Item
{-# INLINE combinationsTrie #-}
combinationsTrie = foldr
(uncurry insertInTrie . first sort)
emptyTrie
itemCombinations
combinationsTrie =
foldl'
(flip $ uncurry insertInTrie . first sort)
emptyTrie
itemCombinations
src/Dodge/Config/KeyConfig.hs
-61
View File
@@ -1,61 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
--{-# LANGUAGE OverloadedStrings #-}
module Dodge.Config.KeyConfig
( KeyConfigSDL (..)
, defaultKeyConfigSDL
, loadKeyConfig
)
where
--import Data.Aeson
--import Foreign.C.Types
import GHC.Generics
--import qualified GHC.Int
import qualified SDL
--import qualified SDL.Internal.Numbered
--import System.Directory
data KeyConfigSDL = KeyConfigSDL
{ moveUpKey :: SDL.Scancode
, moveDownKey :: SDL.Scancode
, moveLeftKey :: SDL.Scancode
, moveRightKey :: SDL.Scancode
, pauseKey :: SDL.Scancode
, escapeKey :: SDL.Scancode
, dropItemKey :: SDL.Scancode
, toggleMapKey :: SDL.Scancode
, reloadKey :: SDL.Scancode
, testEventKey :: SDL.Scancode
, spaceActionKey :: SDL.Scancode
, rotateCameraPlusKey :: SDL.Scancode
, rotateCameraMinusKey :: SDL.Scancode
, zoomInKey :: SDL.Scancode
, zoomOutKey :: SDL.Scancode
, newMapKey :: SDL.Scancode
, modifierKey :: SDL.Scancode
}
deriving (Generic, Show)
defaultKeyConfigSDL :: KeyConfigSDL
defaultKeyConfigSDL =
KeyConfigSDL
{ moveUpKey = SDL.ScancodeW
, moveDownKey = SDL.ScancodeS
, moveLeftKey = SDL.ScancodeA
, moveRightKey = SDL.ScancodeD
, pauseKey = SDL.ScancodeP
, escapeKey = SDL.ScancodeEscape
, dropItemKey = SDL.ScancodeF
, toggleMapKey = SDL.ScancodeM
, reloadKey = SDL.ScancodeR
, testEventKey = SDL.ScancodeT
, spaceActionKey = SDL.ScancodeSpace
, rotateCameraPlusKey = SDL.ScancodeQ
, rotateCameraMinusKey = SDL.ScancodeE
, zoomInKey = SDL.ScancodeJ
, zoomOutKey = SDL.ScancodeK
, newMapKey = SDL.ScancodeN
, modifierKey = SDL.ScancodeCapsLock
}
loadKeyConfig :: IO KeyConfigSDL
loadKeyConfig = return defaultKeyConfigSDL
src/Dodge/CrGroupUpdate.hs
+1 -1
View File
@@ -1,6 +1,6 @@
module Dodge.CrGroupUpdate
where
import Dodge.Data
import Dodge.Data.World
doCrGroupUpdate :: CrGroupUpdate -> World -> CrGroupParams -> Maybe CrGroupParams
doCrGroupUpdate cgu = case cgu of
src/Dodge/Creature.hs
+27 -3
View File
@@ -8,18 +8,42 @@ module Dodge.Creature (
spreadGunCrit,
autoCrit,
armourChaseCrit,
module Dodge.Creature.Action,
module Dodge.Creature.Boid,
module Dodge.Creature.ChainUpdates,
module Dodge.Creature.Impulse,
module Dodge.Creature.Perception,
module Dodge.Creature.ReaderUpdate,
module Dodge.Creature.SentinelAI,
module Dodge.Creature.State,
module Dodge.Creature.Strategy,
module Dodge.Creature.Test,
module Dodge.Creature.Volition,
module Dodge.Creature.YourControl,
) where
import Control.Lens
import Dodge.Creature.Action
import Dodge.Creature.ArmourChase
import Dodge.Creature.AutoCrit
import Dodge.Creature.Boid
import Dodge.Creature.ChainUpdates
import Dodge.Creature.ChaseCrit
import Dodge.Creature.Impulse
import Dodge.Creature.Inanimate
import Dodge.Creature.LauncherCrit
import Dodge.Creature.LtAutoCrit
import Dodge.Creature.Perception
import Dodge.Creature.PistolCrit
import Dodge.Creature.ReaderUpdate
import Dodge.Creature.SentinelAI
import Dodge.Creature.SpreadGunCrit
import Dodge.Data
import Dodge.Creature.State
import Dodge.Creature.Strategy
import Dodge.Creature.Test
import Dodge.Creature.Volition
import Dodge.Creature.YourControl
import Dodge.Data.Creature
import Dodge.Default
import Dodge.Item
import Geometry.Data
@@ -43,8 +67,8 @@ miniGunCrit =
longCrit :: Creature
longCrit =
defaultCreature
& crActionPlan .~
ActionPlan
& crActionPlan
.~ ActionPlan
{ _apImpulse = []
, _apAction = []
, _apStrategy = StrategyActions WatchAndWait [StartSentinelPost]
src/Dodge/Creature.hs.orig
+1 -1
View File
@@ -4,7 +4,7 @@ module Dodge.Creature
)
where
-- imports {{{
import Dodge.Data
import Dodge.Data.Creature
import Dodge.AIs
import Dodge.CreatureState
import Dodge.Default
src/Dodge/Creature/Action.hs
+2 -1
View File
@@ -17,12 +17,13 @@ module Dodge.Creature.Action (
pickUpItem,
pickUpItemID,
) where
import Data.Bifunctor
import Data.List (findIndex)
import Data.Maybe
import Dodge.Base
import Dodge.CreatureEffect
import Dodge.Data
import Dodge.Data.World
import Dodge.Default
import Dodge.FloatFunction
import Dodge.FloorItem
src/Dodge/Creature/ArmourChase.hs
+43 -37
View File
@@ -1,45 +1,51 @@
module Dodge.Creature.ArmourChase
( armourChaseCrit
, flockArmourChaseCrit
) where
import Dodge.Data
module Dodge.Creature.ArmourChase (
armourChaseCrit,
flockArmourChaseCrit,
) where
import Control.Lens
import Dodge.Creature.ChaseCrit
import Dodge.Data.Creature
import Dodge.Data.FloatFunction
import Dodge.Default
import Dodge.Creature.ChaseCrit
import Dodge.Item.Equipment
import Dodge.Item.Consumable
import Dodge.Item.Equipment
import qualified IntMapHelp as IM
import Control.Lens
flockArmourChaseCrit :: Creature
flockArmourChaseCrit = defaultCreature
{ _crName = "armourChaseCrit"
, _crHP = 300
, _crInv = IM.fromList
[(0,frontArmour)
,(1,medkit 200)
]
, _crActionPlan = ActionPlan
{_apImpulse = []
,_apAction = []
,_apStrategy = FollowImpulses
,_apGoal = [Kill 0]
flockArmourChaseCrit =
defaultCreature
{ _crName = "armourChaseCrit"
, _crHP = 300
, _crInv =
IM.fromList
[ (0, frontArmour)
, (1, medkit 200)
]
, _crActionPlan =
ActionPlan
{ _apImpulse = []
, _apAction = []
, _apStrategy = FollowImpulses
, _apGoal = [Kill 0]
}
, _crMeleeCooldown = 0
, _crGroup = ShieldGroup
, _crMvType = defaultChaseMvType
}
, _crMeleeCooldown = 0
, _crGroup = ShieldGroup
, _crMvType = defaultChaseMvType
}
& crType . humanoidAI .~ FlockArmourChaseAI
& crType . humanoidAI .~ FlockArmourChaseAI
armourChaseCrit :: Creature
armourChaseCrit = chaseCrit
{ _crName = "armourChaseCrit"
--, _crUpdate = defaultImpulsive []
, _crInv = IM.fromList
[(0,frontArmour)
,(1,medkit 200)
]
, _crMvType = defaultChaseMvType {_mvTurnRad = FloatConst 0.05}
}
& crEquipment . at OnChest ?~ 0
& crInvEquipped . at 0 ?~ OnChest
armourChaseCrit =
chaseCrit
{ _crName = "armourChaseCrit"
, --, _crUpdate = defaultImpulsive []
_crInv =
IM.fromList
[ (0, frontArmour)
, (1, medkit 200)
]
, _crMvType = defaultChaseMvType{_mvTurnRad = FloatConst 0.05}
}
& crEquipment . at OnChest ?~ 0
& crInvEquipped . at 0 ?~ OnChest
src/Dodge/Creature/AutoCrit.hs
+17 -16
View File
@@ -1,21 +1,22 @@
module Dodge.Creature.AutoCrit
( autoCrit
) where
import Dodge.Data
module Dodge.Creature.AutoCrit (
autoCrit,
) where
import Dodge.Item.Held.Cane
import Control.Lens
import Dodge.Data.Creature
import Dodge.Default
import Dodge.Item.Weapon.BulletGuns
import Dodge.Item.Consumable
import qualified IntMapHelp as IM
import Picture
import qualified IntMapHelp as IM
import Control.Lens
autoCrit :: Creature
autoCrit = defaultCreature
{ _crInv = IM.fromList [(0,autoRifle),(1,medkit 100)]
, _crRad = 10
, _crHP = 300
, _crMvType = defaultAimMvType
}
& crType . skinUpper .~ light4 red
& crType . humanoidAI .~ AutoAI
autoCrit =
defaultCreature
{ _crInv = IM.fromList [(0, autoRifle), (1, medkit 100)]
, _crRad = 10
, _crHP = 300
, _crMvType = defaultAimMvType
}
& crType . skinUpper .~ light4 red
& crType . humanoidAI .~ AutoAI
src/Dodge/Creature/Boid.hs
+134 -117
View File
@@ -1,20 +1,19 @@
module Dodge.Creature.Boid
where
import Dodge.Data
import Dodge.Base
import Geometry
--import Geometry.ConvexPoly
module Dodge.Creature.Boid where
import Control.Monad.Reader
import Control.Lens
import Control.Monad.Reader
import Dodge.Base
import Dodge.Data.World
import Geometry
import qualified IntMapHelp as IM
interpWith :: Float -> Point2 -> Point2 -> Point2
interpWith x a b = x *.* a +.+ (1 - x) *.* b
invertEncircleDistP :: Float -> Creature -> Point2 -> Creature -> Point2
invertEncircleDistP d tcr cenp cr = ypos +.+
d *.* reflectIn (cenp -.- ypos) (squashNormalizeV (cpos -.- cenp))
invertEncircleDistP d tcr cenp cr =
ypos
+.+ d *.* reflectIn (cenp -.- ypos) (squashNormalizeV (cpos -.- cenp))
where
cpos = _crPos cr
ypos = _crPos tcr
@@ -30,21 +29,22 @@ encircleP tcr cenp cr = ypos +.+ 50 *.* squashNormalizeV (cpos -.- cenp)
where
cpos = _crPos cr
ypos = _crPos tcr
--f x = 150 * sigmoid (x-10)
--f x = 150 * sigmoid (x-10)
encircleCloseP :: Creature -> Point2 -> Creature -> Point2
encircleCloseP tcr cenp cr = ypos +.+ f (max 0 (magV (ypos -.- cenp) - 80) ) *.* squashNormalizeV (cpos -.- cenp)
encircleCloseP tcr cenp cr = ypos +.+ f (max 0 (magV (ypos -.- cenp) - 80)) *.* squashNormalizeV (cpos -.- cenp)
where
cpos = _crPos cr
ypos = _crPos tcr
f x = 150 * sigmoid (x-10)
f x = 150 * sigmoid (x -10)
forbidFlee
:: (Creature -> Point2 -> Creature -> Point2)
-> Creature
-> Point2
-> Creature
-> Point2
forbidFlee ::
(Creature -> Point2 -> Creature -> Point2) ->
Creature ->
Point2 ->
Creature ->
Point2
forbidFlee f tcr cenp cr
| ptargTest = tpos
| otherwise = ptarg
@@ -52,9 +52,10 @@ forbidFlee f tcr cenp cr
cpos = _crPos cr
tpos = _crPos tcr
ptarg = f tcr cenp cr
ptargTest = isLHS cpos (cpos +.+ rotateV (negate (pi/2)) (cpos -.- tpos)) ptarg
-- && isRHS cpos (cpos +.+ rotateV (pi/3) (cpos -.- tpos)) ptarg
--targBehindCrit = isLHS cpos (vNormal $ cpos +.+ unitVectorAtAngle (_crDir cr)) ptarg
ptargTest = isLHS cpos (cpos +.+ rotateV (negate (pi / 2)) (cpos -.- tpos)) ptarg
-- && isRHS cpos (cpos +.+ rotateV (pi/3) (cpos -.- tpos)) ptarg
--targBehindCrit = isLHS cpos (vNormal $ cpos +.+ unitVectorAtAngle (_crDir cr)) ptarg
pincerP :: Creature -> Point2 -> Creature -> Point2
pincerP tcr cenp cr = tpos +.+ splitp -- +.+ 25 *.* (normalizeV $ tpos -.- cenp)
@@ -62,10 +63,10 @@ pincerP tcr cenp cr = tpos +.+ splitp -- +.+ 25 *.* (normalizeV $ tpos -.- cenp)
cpos = _crPos cr
tpos = _crPos tcr
splitp
| isLHS cenp cpos tpos
= 150 *.* orthCenpTpos
| otherwise
= negate 150 *.* orthCenpTpos
| isLHS cenp cpos tpos =
150 *.* orthCenpTpos
| otherwise =
negate 150 *.* orthCenpTpos
--d = min 150 (dist cpos tpos)
--orthCenpTpos = safeNormalizeV (vNormal $ tpos -.- cpos)
orthCenpTpos = squashNormalizeV (vNormal $ tpos -.- cenp)
@@ -76,49 +77,49 @@ pincerP''' tcr cenp cr = interpWith (sigmoid $ 0.05 * dtcen) cenawayp cenclosep
cpos = _crPos cr
tpos = _crPos tcr
dtcen = dist tpos cenp
f x = 150 * sigmoid (x-10)
f x = 150 * sigmoid (x -10)
cenawayp
| dist cenp tpos < dist cpos tpos = tpos +.+ splitp
| otherwise = cenp +.+ splitp
splitp
| isLHS cenp cpos tpos
= f (max 0 (magV (tpos -.- cenp) - 80) ) *.* orthCenpTpos
| otherwise
= negate ( f $ max 0 $ magV (tpos -.- cenp) - 80) *.* orthCenpTpos
| isLHS cenp cpos tpos =
f (max 0 (magV (tpos -.- cenp) - 80)) *.* orthCenpTpos
| otherwise =
negate (f $ max 0 $ magV (tpos -.- cenp) - 80) *.* orthCenpTpos
orthCenpTpos = squashNormalizeV (vNormal $ tpos -.- cenp)
cenclosep
= tpos +.+ f (max 0 (magV (tpos -.- cenp) - 80) ) *.* squashNormalizeV (cpos -.- cenp)
cenclosep =
tpos +.+ f (max 0 (magV (tpos -.- cenp) - 80)) *.* squashNormalizeV (cpos -.- cenp)
pincerP' :: Creature -> Point2 -> Creature -> Point2
pincerP' tcr cenp cr
| dist cenp tpos > dist cpos tpos
= cenp +.+ f (max 0 (magV (tpos -.- cenp) - 80) ) *.* squashNormalizeV (cpos -.- cenp)
| otherwise = tpos +.+ f (max 0 (magV (tpos -.- cenp) - 80) ) *.* squashNormalizeV (cpos -.- cenp)
| dist cenp tpos > dist cpos tpos =
cenp +.+ f (max 0 (magV (tpos -.- cenp) - 80)) *.* squashNormalizeV (cpos -.- cenp)
| otherwise = tpos +.+ f (max 0 (magV (tpos -.- cenp) - 80)) *.* squashNormalizeV (cpos -.- cenp)
where
cpos = _crPos cr
tpos = _crPos tcr
f x = 150 * sigmoid (x-10)
f x = 150 * sigmoid (x -10)
pincerP'' :: Creature -> Point2 -> Creature -> Point2
pincerP'' tcr cenp cr
| dist cenp tpos > dist cpos tpos && isLHS cenp cpos tpos
= cenp +.+ f (max 0 (magV (tpos -.- cenp) - 80) ) *.* squashNormalizeV (vNormal $ tpos -.- cenp)
| dist cenp tpos > dist cpos tpos
= cenp +.+ f (max 0 (magV (tpos -.- cenp) - 80) ) *.* squashNormalizeV (vNormal $ cenp -.- tpos)
| otherwise = tpos +.+ f (max 0 (magV (tpos -.- cenp) - 80) ) *.* squashNormalizeV (cpos -.- cenp)
| dist cenp tpos > dist cpos tpos && isLHS cenp cpos tpos =
cenp +.+ f (max 0 (magV (tpos -.- cenp) - 80)) *.* squashNormalizeV (vNormal $ tpos -.- cenp)
| dist cenp tpos > dist cpos tpos =
cenp +.+ f (max 0 (magV (tpos -.- cenp) - 80)) *.* squashNormalizeV (vNormal $ cenp -.- tpos)
| otherwise = tpos +.+ f (max 0 (magV (tpos -.- cenp) - 80)) *.* squashNormalizeV (cpos -.- cenp)
where
cpos = _crPos cr
tpos = _crPos tcr
f x = 150 * sigmoid (x-10)
f x = 150 * sigmoid (x -10)
encircle :: Creature -> IM.IntMap Creature -> Creature -> Point2
encircle tcr crs cr
| length crs <= 1 = ypos
| otherwise = ypos +.+ f (max 0 (magV (ypos -.- cenp) - 80) ) *.* squashNormalizeV (cpos -.- cenp)
| otherwise = ypos +.+ f (max 0 (magV (ypos -.- cenp) - 80)) *.* squashNormalizeV (cpos -.- cenp)
where
cpos = _crPos cr
ypos = _crPos tcr
f x = 150 * sigmoid (x-10)
f x = 150 * sigmoid (x -10)
cenp = centroid (map _crPos $ IM.elems crs)
lineOrth :: Creature -> IM.IntMap Creature -> Creature -> Point2
@@ -128,7 +129,8 @@ lineOrth tcr crs cr = p
cpos = _crPos cr
ps = map _crPos $ IM.elems crs
cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps
p | dist cen ypos < 20 = ypos
p
| dist cen ypos < 20 = ypos
| otherwise = errorClosestPointOnLine 500 ypos (ypos +.+ vNormal (cen -.- ypos)) cpos
holdForm :: Creature -> IM.IntMap Creature -> Creature -> Point2
@@ -138,7 +140,8 @@ holdForm ycr crs cr = p
cpos = _crPos cr
ps = map _crPos $ IM.elems crs
cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps
p | dist cen ypos < 20 = ypos
p
| dist cen ypos < 20 = ypos
| otherwise = ypos +.+ cpos -.- cen
lineUp :: Creature -> IM.IntMap Creature -> Creature -> Point2
@@ -158,18 +161,19 @@ spreadOut ycr crs cr = p
cpos = _crPos cr
ps = map _crPos $ IM.elems crs
cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps
p | dist cen ypos < 30 = ypos
p
| dist cen ypos < 30 = ypos
| otherwise = ypos +.+ (spreadFactor *.* cpos -.- cen)
spreadFactor
| dist ypos cpos > 90 = 1
| otherwise = 1.5
swarmUsingCenter
:: (Creature -> Point2 -> Creature -> Creature)
-> (Point2 -> Creature -> Creature)
-> World
-> Creature
-> Creature
swarmUsingCenter ::
(Creature -> Point2 -> Creature -> Creature) ->
(Point2 -> Creature -> Creature) ->
World ->
Creature ->
Creature
swarmUsingCenter updT upd w cr = case _targetCr $ _crIntention cr of
Nothing -> upd cenp cr
Just tcr -> updT tcr cenp cr
@@ -177,12 +181,14 @@ swarmUsingCenter updT upd w cr = case _targetCr $ _crIntention cr of
cid = _crID cr
cenp = _crGroupCenter $ _creatureGroups (_cWorld w) IM.! _crGroupID (_crGroup $ _creatures (_cWorld w) IM.! cid)
flockChaseTarget
:: (Creature -> IM.IntMap Creature -> Creature -> Creature) -- ^ Update with target
-> (IM.IntMap Creature -> Creature -> Creature) -- ^ Update without target
-> World
-> Creature
-> Creature
flockChaseTarget ::
-- | Update with target
(Creature -> IM.IntMap Creature -> Creature -> Creature) ->
-- | Update without target
(IM.IntMap Creature -> Creature -> Creature) ->
World ->
Creature ->
Creature
flockChaseTarget updT upd w cr = case _targetCr $ _crIntention cr of
Nothing -> upd crs cr
Just tcr -> updT tcr crs cr
@@ -190,12 +196,13 @@ flockChaseTarget updT upd w cr = case _targetCr $ _crIntention cr of
is = _swarm $ _crGroup cr
crs = IM.restrictKeys (_creatures (_cWorld w)) is
flockPointTarget
:: (Creature -> IM.IntMap Creature -> Creature -> Point2)
-> (Creature -> World -> Maybe Creature) -- ^ Function for determining target
-> World
-> Creature
-> Creature
flockPointTarget ::
(Creature -> IM.IntMap Creature -> Creature -> Point2) ->
-- | Function for determining target
(Creature -> World -> Maybe Creature) ->
World ->
Creature ->
Creature
flockPointTarget f targFunc w cr = case targFunc cr w of
Nothing -> cr
Just crTarg -> cr & crActionPlan . apImpulse .~ mvPointMeleeTarg p cr crTarg
@@ -204,23 +211,24 @@ flockPointTarget f targFunc w cr = case targFunc cr w of
crs = IM.restrictKeys (_creatures (_cWorld w)) is
p = f crTarg crs cr
flockToPointUsing
:: (Creature -> Point2 -> Creature -> Point2)
-> (Point2 -> Creature -> Creature -> [Impulse])
-> Creature
-> Reader World Creature
flockToPointUsing ::
(Creature -> Point2 -> Creature -> Point2) ->
(Point2 -> Creature -> Creature -> [Impulse]) ->
Creature ->
Reader World Creature
flockToPointUsing pf mvf cr = reader $ \w -> case _targetCr $ _crIntention cr of
Nothing -> cr
Just tcr -> cr & crActionPlan . apImpulse .~ mvf ptarg cr tcr
where
cenp = _crGroupCenter $ _creatureGroups (_cWorld w) IM.! _crGroupID (_crGroup cr)
ptarg = pf tcr cenp cr
flockToPointUsing'
:: (Creature -> Point2 -> Creature -> Point2)
-> (Point2 -> Creature -> Creature -> [Impulse])
-> World
-> Creature
-> Creature
flockToPointUsing' ::
(Creature -> Point2 -> Creature -> Point2) ->
(Point2 -> Creature -> Creature -> [Impulse]) ->
World ->
Creature ->
Creature
flockToPointUsing' pf mvf w cr = case _targetCr $ _crIntention cr of
Nothing -> cr
Just tcr -> cr & crActionPlan . apImpulse .~ mvf ptarg cr tcr
@@ -228,11 +236,12 @@ flockToPointUsing' pf mvf w cr = case _targetCr $ _crIntention cr of
cenp = _crGroupCenter $ _creatureGroups (_cWorld w) IM.! _crGroupID (_crGroup cr)
ptarg = pf tcr cenp cr
flockFunc
:: (Creature -> Point2 -> Creature -> Point2)
-> (Creature -> World -> Maybe Creature) -- ^ Function for determining target
-> Creature
-> Reader World Creature
flockFunc ::
(Creature -> Point2 -> Creature -> Point2) ->
-- | Function for determining target
(Creature -> World -> Maybe Creature) ->
Creature ->
Reader World Creature
flockFunc f targFunc cr = reader $ \w -> case targFunc cr w of
Nothing -> cr
Just crTarg -> cr & crActionPlan . apImpulse .~ mvPointMeleeTarg p cr crTarg
@@ -240,11 +249,12 @@ flockFunc f targFunc cr = reader $ \w -> case targFunc cr w of
cenp = _crGroupCenter $ _creatureGroups (_cWorld w) IM.! _crGroupID (_crGroup cr)
p = f crTarg cenp cr
flockCenterFunc
:: (Creature -> Point2 -> Creature -> Point2)
-> (Creature -> World -> Maybe Creature) -- ^ Function for determining target
-> Creature
-> Reader World Creature
flockCenterFunc ::
(Creature -> Point2 -> Creature -> Point2) ->
-- | Function for determining target
(Creature -> World -> Maybe Creature) ->
Creature ->
Reader World Creature
flockCenterFunc f targFunc cr = reader $ \w -> case targFunc cr w of
Nothing -> cr
Just crTarg -> cr & crActionPlan . apImpulse .~ mvPointMeleeTarg p cr crTarg
@@ -252,11 +262,12 @@ flockCenterFunc f targFunc cr = reader $ \w -> case targFunc cr w of
cenp = _crGroupCenter $ _creatureGroups (_cWorld w) IM.! _crGroupID (_crGroup cr)
p = f crTarg cenp cr
flockPointTargetR
:: (Creature -> IM.IntMap Creature -> Creature -> Point2)
-> (Creature -> World -> Maybe Creature) -- ^ Function for determining target
-> Creature
-> Reader World Creature
flockPointTargetR ::
(Creature -> IM.IntMap Creature -> Creature -> Point2) ->
-- | Function for determining target
(Creature -> World -> Maybe Creature) ->
Creature ->
Reader World Creature
flockPointTargetR f targFunc cr = reader $ \w -> case targFunc cr w of
Nothing -> cr
Just crTarg -> cr & crActionPlan . apImpulse .~ mvPointMeleeTarg p cr crTarg
@@ -265,44 +276,50 @@ flockPointTargetR f targFunc cr = reader $ \w -> case targFunc cr w of
crs = IM.restrictKeys (_creatures (_cWorld w)) is
p = f crTarg crs cr
meleeHeadingMove
:: Float -- ^ max turn speed
-> Float -- ^ min turn speed
-> Float -- ^ turn speed cutoff angle
-> Float -- ^ move speed
-> Point2 -- ^ target point
-> Creature -- ^ start creature
-> Creature -- ^ target creature
-> [Impulse]
meleeHeadingMove ::
-- | max turn speed
Float ->
-- | min turn speed
Float ->
-- | turn speed cutoff angle
Float ->
-- | move speed
Float ->
-- | target point
Point2 ->
-- | start creature
Creature ->
-- | target creature
Creature ->
[Impulse]
meleeHeadingMove maxta minta tacutoff speed tp cr tcr
| dist tpos cpos < combinedRad + 5
&& abs (_crDir cr - argV (tpos -.- cpos)) < tacutoff
&& _crMeleeCooldown cr == 0
= [Melee (_crID tcr), Turn pi]
&& abs (_crDir cr - argV (tpos -.- cpos)) < tacutoff
&& _crMeleeCooldown cr == 0 =
[Melee (_crID tcr), Turn pi]
| dist tpos cpos < combinedRad + 5
&& abs (_crDir cr - argV (tpos -.- cpos)) < tacutoff
= [ TurnToward tpos minta ]
| abs (_crDir cr - argV (tp -.- cpos)) < tacutoff
= [MoveForward speed , TurnToward tp maxta , RandomTurn maxta ]
| otherwise = [MoveForward speed , TurnToward tp minta, RandomTurn maxta ]
&& abs (_crDir cr - argV (tpos -.- cpos)) < tacutoff =
[TurnToward tpos minta]
| abs (_crDir cr - argV (tp -.- cpos)) < tacutoff =
[MoveForward speed, TurnToward tp maxta, RandomTurn maxta]
| otherwise = [MoveForward speed, TurnToward tp minta, RandomTurn maxta]
where
cpos = _crPos cr
tpos = _crPos tcr
combinedRad = _crRad cr + _crRad tcr
mvPointMeleeTarg :: Point2 -> Creature -> Creature -> [Impulse]
mvPointMeleeTarg p cr crT
| dist tpos cpos < combinedRad + 5
&& abs (_crDir cr - argV (tpos -.- cpos)) < pi/4
&& _crMeleeCooldown cr == 0
= [Melee (_crID crT)]
&& abs (_crDir cr - argV (tpos -.- cpos)) < pi / 4
&& _crMeleeCooldown cr == 0 =
[Melee (_crID crT)]
| dist tpos cpos < combinedRad + 5
&& abs (_crDir cr - argV (tpos -.- cpos)) < pi/4
= [ TurnToward tpos 0.05 ]
| abs (_crDir cr - argV (p -.- cpos)) < pi/4
= [MoveForward 3 , TurnToward p 0.2 , RandomTurn 0.2 ]
| otherwise = [MoveForward 3 , TurnToward p 0.05, RandomTurn 0.2 ]
&& abs (_crDir cr - argV (tpos -.- cpos)) < pi / 4 =
[TurnToward tpos 0.05]
| abs (_crDir cr - argV (p -.- cpos)) < pi / 4 =
[MoveForward 3, TurnToward p 0.2, RandomTurn 0.2]
| otherwise = [MoveForward 3, TurnToward p 0.05, RandomTurn 0.2]
where
cpos = _crPos cr
tpos = _crPos crT
src/Dodge/Creature/ChainUpdates.hs
+6 -4
View File
@@ -1,11 +1,13 @@
module Dodge.Creature.ChainUpdates where
import Dodge.Data
import Data.Foldable
import Dodge.Data.World
chainCreatureUpdates
:: [World -> Creature -> Creature]
-> World -> Creature -> Creature
chainCreatureUpdates ::
[World -> Creature -> Creature] ->
World ->
Creature ->
Creature
chainCreatureUpdates ls w cr = foldl' unf cr ls
where
unf cr' g = g w cr'
src/Dodge/Creature/ChaseCrit.hs
+48 -40
View File
@@ -1,49 +1,57 @@
module Dodge.Creature.ChaseCrit
(smallChaseCrit
,invisibleChaseCrit
,chaseCrit
) where
import Dodge.Data
module Dodge.Creature.ChaseCrit (
smallChaseCrit,
invisibleChaseCrit,
chaseCrit,
) where
import Control.Lens
import Dodge.Data.Creature
import Dodge.Default
import Dodge.Item.Consumable
import Dodge.Item.Equipment
import Dodge.SoundLogic
import qualified IntMapHelp as IM
import Picture
import qualified IntMapHelp as IM
import Control.Lens
--import System.Random
smallChaseCrit :: Creature
smallChaseCrit = chaseCrit
{ _crHP = 1
, _crRad = 4
, _crInv = IM.fromList [(0,medkit 200)]
, _crCorpse = MakeDefaultCorpse
}
smallChaseCrit =
chaseCrit
{ _crHP = 1
, _crRad = 4
, _crInv = IM.fromList [(0, medkit 200)]
, _crCorpse = MakeDefaultCorpse
}
invisibleChaseCrit :: Creature
invisibleChaseCrit = chaseCrit
& crCamouflage .~ Invisible
& crInv . at 0 ?~ wristInvisibility
& crEquipment . at OnLeftWrist ?~ 0
& crInvEquipped . at 0 ?~ OnLeftWrist
invisibleChaseCrit =
chaseCrit
& crCamouflage .~ Invisible
& crInv . at 0 ?~ wristInvisibility
& crEquipment . at OnLeftWrist ?~ 0
& crInvEquipped . at 0 ?~ OnLeftWrist
chaseCrit :: Creature
chaseCrit = defaultCreature
{ _crName = "chaseCrit"
, _crHP = 150
, _crInv = IM.fromList [(0,medkit 200)]
, _crMeleeCooldown = 0
, _crFaction = ColorFaction green
, _crVocalization = Vocalization seagullChatterS
[seagullBarkS
,seagullChatterS
,seagullChatter1S
,seagullWhistleS
,seagullWhistle1S
,seagullCryS
,seagullCry1S
,seagullCry2S
] 50 0
, _crMvType = defaultChaseMvType
}
& crType . humanoidAI .~ ChaseAI
chaseCrit =
defaultCreature
{ _crName = "chaseCrit"
, _crHP = 150
, _crInv = IM.fromList [(0, medkit 200)]
, _crMeleeCooldown = 0
, _crFaction = ColorFaction green
, _crVocalization =
Vocalization
seagullChatterS
[ seagullBarkS
, seagullChatterS
, seagullChatter1S
, seagullWhistleS
, seagullWhistle1S
, seagullCryS
, seagullCry1S
, seagullCry2S
]
50
0
, _crMvType = defaultChaseMvType
}
& crType . humanoidAI .~ ChaseAI
src/Dodge/Creature/ChooseTarget.hs
+5 -7
View File
@@ -1,10 +1,8 @@
module Dodge.Creature.ChooseTarget
where
import Dodge.Data
import Dodge.Base
module Dodge.Creature.ChooseTarget where
import Control.Lens
--import qualified IntMapHelp as IM
import Dodge.Base
import Dodge.Data.World
targetYouLOS :: Creature -> World -> Maybe Creature
{-# INLINE targetYouLOS #-}
@@ -15,8 +13,8 @@ targetYouLOS cr w
targetYouCognizant :: Creature -> World -> Maybe Creature
targetYouCognizant cr w
| hasLOS (_crPos cr) (_crPos $ you w) w
&& isCog (cr ^? crPerception . cpAwareness . ix 0)
= Just $ you w
&& isCog (cr ^? crPerception . cpAwareness . ix 0) =
Just $ you w
| otherwise = Nothing
where
isCog x = case x of
src/Dodge/Creature/Damage.hs
+28 -23
View File
@@ -1,14 +1,13 @@
module Dodge.Creature.Damage where
import Dodge.Data
import Dodge.Creature.Test
import Dodge.Spark
--import Dodge.Bullet
import Color
import Data.List
import Dodge.Creature.Test
import Dodge.Data.World
import Dodge.Spark
import Geometry
import LensHelp
import Data.List
applyNoDamage :: [Damage] -> Creature -> World -> World
applyNoDamage _ _ = id
@@ -16,34 +15,39 @@ applyCreatureDamage :: [Damage] -> Creature -> World -> World
applyCreatureDamage dms cr = case _crMaterial cr of
Flesh -> defaultApplyDamage dms cr
Crystal -> id
_-> defaultApplyDamage dms cr
_ -> defaultApplyDamage dms cr
defaultApplyDamage :: [Damage] -> Creature -> World -> World
defaultApplyDamage ds cr w = foldl' (applyIndividualDamage cr) w ds'
& cWorld . creatures . ix (_crID cr) %~ doPoisonDam
defaultApplyDamage ds cr w =
foldl' (applyIndividualDamage cr) w ds'
& cWorld . creatures . ix (_crID cr) %~ doPoisonDam
where
(ps,ds') = partition isPoison ds
isPoison Damage{_dmType=POISONDAM} = True
(ps, ds') = partition isPoison ds
isPoison Damage{_dmType = POISONDAM} = True
isPoison _ = False
poisonDam = quot (max 0 (sum (map _dmAmount ps))) 10
doPoisonDam = crHP -~ poisonDam
applyDamageEffect :: Damage -> DamageEffect -> Creature -> World -> World
applyDamageEffect dm de cr w = case de of
PushDamage push pushexp pushRad -> w
& cWorld . creatures . ix (_crID cr) . crPos .+.+~ pushAmount *.* squashNormalizeV (_crPos cr -.- fromDir)
PushDamage push pushexp pushRad ->
w
& cWorld . creatures . ix (_crID cr) . crPos .+.+~ pushAmount *.* squashNormalizeV (_crPos cr -.- fromDir)
where
pushAmount
| dist (_crPos cr) fromDir == 0 = 0
| otherwise = min 5 $ (push*5*pushRad / (dist (_crPos cr) fromDir * _crMass cr))**pushexp
PushBackDamage pback -> w
& cWorld . creatures . ix (_crID cr) . crPos .+.+~ (pback/_crMass cr) *.* (_dmTo dm -.- fromDir)
TorqueDamage rot -> w
& cWorld . creatures . ix (_crID cr) . crDir +~ rot
| otherwise = min 5 $ (push * 5 * pushRad / (dist (_crPos cr) fromDir * _crMass cr)) ** pushexp
PushBackDamage pback ->
w
& cWorld . creatures . ix (_crID cr) . crPos .+.+~ (pback / _crMass cr) *.* (_dmTo dm -.- fromDir)
TorqueDamage rot ->
w
& cWorld . creatures . ix (_crID cr) . crDir +~ rot
NoDamageEffect -> w
where
fromDir = _dmFrom dm
--p = _dmAt dm
--p = _dmAt dm
applyIndividualDamage :: Creature -> World -> Damage -> World
applyIndividualDamage cr w dm = applyDamageEffect dm (_dmEffect dm) cr $ applyIndividualDamage' cr w dm
@@ -62,7 +66,8 @@ applyPiercingDamage cr dm
p1 = p +.+ 2 *.* squashNormalizeV (p -.- _crPos cr)
damageHP :: Creature -> Int -> World -> World
damageHP cr x = cWorld . creatures . ix (_crID cr) %~
( (crHP -~ x)
. (crPastDamage +~ x)
)
damageHP cr x =
cWorld . creatures . ix (_crID cr)
%~ ( (crHP -~ x)
. (crPastDamage +~ x)
)
src/Dodge/Creature/HandPos.hs
+52 -42
View File
@@ -1,33 +1,36 @@
module Dodge.Creature.HandPos where
import Dodge.Data
import Dodge.Creature.Test
--import Shape
import ShapePicture
import Geometry
import Control.Lens
import Data.Maybe
import Dodge.Creature.Test
import Dodge.Data.Creature
import Geometry
import ShapePicture
-- the position of a weapon handle
aimingWeaponHandlePos :: Creature -> Item -> Float
aimingWeaponHandlePos cr it = case it ^? itUse. useAim . aimStance of
Just TwoHandTwist -> -5
Just OneHand -> 14
Just TwoHandFlat -> 1.2 * _crRad cr
aimingWeaponHandlePos cr it = case it ^? itUse . heldAim . aimStance of
Just TwoHandTwist -> -5
Just OneHand -> 14
Just TwoHandFlat -> 1.2 * _crRad cr
Just LeaveHolstered -> 0
Nothing -> 0
Nothing -> 0
aimingWeaponZeroPos :: Creature -> Item -> Float
aimingWeaponZeroPos cr it = aimingWeaponHandlePos cr it
- fromMaybe 0 (it ^? itUse . useAim . aimHandlePos)
aimingWeaponZeroPos cr it =
aimingWeaponHandlePos cr it
- fromMaybe 0 (it ^? itUse . heldAim . aimHandlePos)
aimingMuzzlePos :: Creature -> Item -> Float
aimingMuzzlePos cr it = aimingWeaponZeroPos cr it
+ fromMaybe 0 (it ^? itUse . useAim . aimMuzPos)
aimingMuzzlePos cr it =
aimingWeaponZeroPos cr it
+ fromMaybe 0 (it ^? itUse . heldAim . aimMuzPos)
translatePointToRightHand :: Creature -> Point3 -> Point3
translatePointToRightHand cr = translatePointToRightHand' cr . mirrorV3xz
mirrorV3xz :: Point3 -> Point3
mirrorV3xz (V3 x y z) = V3 x (-y) z
mirrorV3xz (V3 x y z) = V3 x (- y) z
translatePointToRightHand' :: Creature -> Point3 -> Point3
translatePointToRightHand' cr
@@ -35,8 +38,8 @@ translatePointToRightHand' cr
| twists cr = (+.+.+ V3 0 5 20) . rotate3 (-1) . (+.+.+ V3 4 (-10) 0)
| twoFlat cr = (+.+.+ V3 4 (-8) 10)
| otherwise = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> (+.+.+ V3 (-f sa) (-off) 10)
_ -> (+.+.+ V3 0 (-off) 10)
Just (Walking sa LeftForward) -> (+.+.+ V3 (- f sa) (- off) 10)
_ -> (+.+.+ V3 0 (- off) 10)
where
off = 8
sLen = _strideLength $ _crStance cr
@@ -47,12 +50,12 @@ translateToRightHand cr = translateToRightHand' cr . mirrorSPxz
translateToRightHand' :: Creature -> SPic -> SPic
translateToRightHand' cr
| oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5)-- . scaleSH (V3 1 1.5 1)
| oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5) -- . scaleSH (V3 1 1.5 1)
| twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 4 (-10)
| twoFlat cr = waistSP . translateSPf 4 (-8)
| otherwise = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> waistSP . translateSPf (-f sa) (-off)
_ -> waistSP . translateSPf 0 (-off)
Just (Walking sa LeftForward) -> waistSP . translateSPf (- f sa) (- off)
_ -> waistSP . translateSPf 0 (- off)
where
off = 8
sLen = _strideLength $ _crStance cr
@@ -63,12 +66,12 @@ translateToRightWrist cr = translateToRightWrist' cr . mirrorSPxz
translateToRightWrist' :: Creature -> SPic -> SPic
translateToRightWrist' cr
| oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5) . offTrans-- . scaleSH (V3 1 1.5 1)
| oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5) . offTrans -- . scaleSH (V3 1 1.5 1)
| twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 4 (-10) . offTrans
| twoFlat cr = waistSP . translateSPf 4 (-8) . offTrans
| otherwise = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> waistSP . translateSPf (-f sa) (-off) . offTrans
_ -> waistSP . translateSPf 0 (-off) . offTrans
Just (Walking sa LeftForward) -> waistSP . translateSPf (- f sa) (- off) . offTrans
_ -> waistSP . translateSPf 0 (- off) . offTrans
where
offTrans = translateSP (V3 0 4 (-4))
off = 8
@@ -81,7 +84,7 @@ translatePointToLeftHand cr
| twists cr = (+.+.+ V3 0 5 20) . rotate3 (-1) . (+.+.+ V3 12 4 0) . rotate3 0.4
| twoFlat cr = (+.+.+ V3 4 8 10)
| otherwise = case cr ^? crStance . carriage of
Just (Walking sa RightForward) -> (+.+.+ V3 (-f sa) off 10)
Just (Walking sa RightForward) -> (+.+.+ V3 (- f sa) off 10)
_ -> (+.+.+ V3 0 off 10)
where
off = 8
@@ -94,7 +97,7 @@ translateToLeftHand cr
| twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 12 4
| twoFlat cr = waistSP . translateSPf 4 8
| otherwise = case cr ^? crStance . carriage of
Just (Walking sa RightForward) -> waistSP . translateSPf (-f sa) off
Just (Walking sa RightForward) -> waistSP . translateSPf (- f sa) off
_ -> waistSP . translateSPf 0 off
where
off = 8
@@ -107,7 +110,7 @@ translateToLeftWrist cr
| twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 12 4 . offTrans
| twoFlat cr = waistSP . translateSPf 4 8 . offTrans
| otherwise = case cr ^? crStance . carriage of
Just (Walking sa RightForward) -> waistSP . translateSPf (-f sa) off . offTrans
Just (Walking sa RightForward) -> waistSP . translateSPf (- f sa) off . offTrans
_ -> waistSP . translateSPf 0 off . offTrans
where
offTrans = translateSP (V3 0 4 (-4))
@@ -116,20 +119,22 @@ translateToLeftWrist cr
f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
translateToLeftLeg :: Creature -> SPic -> SPic
translateToLeftLeg cr = rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> translateSPf ( f sa) off
Just (Walking sa RightForward) -> translateSPf (-f sa) off
_ -> translateSPf 0 off
translateToLeftLeg cr =
rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> translateSPf (f sa) off
Just (Walking sa RightForward) -> translateSPf (- f sa) off
_ -> translateSPf 0 off
where
off = 5
sLen = _strideLength $ _crStance cr
f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
translateToRightLeg :: Creature -> SPic -> SPic
translateToRightLeg cr = rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> translateSPf (-f sa) (-off)
Just (Walking sa RightForward) -> translateSPf ( f sa) (-off)
_ -> translateSPf 0 (-off)
translateToRightLeg cr =
rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> translateSPf (- f sa) (- off)
Just (Walking sa RightForward) -> translateSPf (f sa) (- off)
_ -> translateSPf 0 (- off)
where
off = 5
sLen = _strideLength $ _crStance cr
@@ -137,35 +142,40 @@ translateToRightLeg cr = rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStanc
translateToHead :: Creature -> SPic -> SPic
translateToHead cr
| twists cr = translateSPz 20 . translateSPf 0 5 . rotateSP (-1) . translateSPf (negate 2.5) 0.25
| twists cr =
translateSPz 20 . translateSPf 0 5 . rotateSP (-1) . translateSPf (negate 2.5) 0.25
. rotateSP 1
| oneH cr = translateSPz 20 . rotateSP 0.5 . translateSPf 2.5 0
| oneH cr =
translateSPz 20 . rotateSP 0.5 . translateSPf 2.5 0
. rotateSP (negate 0.5)
| otherwise = translateSPz 20 . translateSPf 2.5 0
translatePointToHead :: Creature -> Point3 -> Point3
translatePointToHead cr
| twists cr = (+.+.+ V3 0 5 20) . rotate3 (-1) . (+.+.+ V3 (negate 2.5) 0.25 0)
| twists cr =
(+.+.+ V3 0 5 20) . rotate3 (-1) . (+.+.+ V3 (negate 2.5) 0.25 0)
. rotate3 1
| oneH cr = (+.+.+ V3 0 0 20) . rotate3 0.5 . (+.+.+ V3 2.5 0 0)
| oneH cr =
(+.+.+ V3 0 0 20) . rotate3 0.5 . (+.+.+ V3 2.5 0 0)
. rotate3 (negate 0.5)
| otherwise = (+.+.+ V3 2.5 0 20)
translateToChest :: Creature -> SPic -> SPic
translateToChest cr
| oneH cr = rotateSP 0.5
-- | twists cr = translateSPf 0 5 . rotateSP (-1)
| oneH cr = rotateSP 0.5
-- | twists cr = translateSPf 0 5 . rotateSP (-1)
| twists cr = rotateSP (-1)
| otherwise = id
translateToBack :: Creature -> SPic -> SPic
translateToBack cr
| oneH cr = rotateSP 0.5
-- | twists cr = translateSPf 0 5 . rotateSP (-1)
| oneH cr = rotateSP 0.5
-- | twists cr = translateSPf 0 5 . rotateSP (-1)
| twists cr = rotateSP (-1)
| otherwise = id
shoulderSP :: SPic -> SPic
shoulderSP = translateSPz 20
waistSP :: SPic -> SPic
waistSP = translateSPz 10
src/Dodge/Creature/Impulse.hs
+74 -66
View File
@@ -1,91 +1,98 @@
{-# LANGUAGE TupleSections #-}
module Dodge.Creature.Impulse
( impulsiveAIBefore
, followThenClearImpulses
) where
import Dodge.Data
import Dodge.FloatFunction
import Dodge.RandImpulse
import Dodge.CreatureEffect
import Dodge.Creature.Vocalization
import Dodge.Creature.Impulse.Movement
import Dodge.Creature.Impulse.UseItem
import Dodge.SoundLogic
import Geometry
import LensHelp
import qualified IntMapHelp as IM
import System.Random
module Dodge.Creature.Impulse (
impulsiveAIBefore,
followThenClearImpulses,
) where
import Control.Monad.State
import Data.Bifunctor
--import Data.Maybe
--
impulsiveAIBeforeAfter
:: (World -> Creature -> Creature)
-> (World -> Creature -> Creature)
-> Creature -> World -> World
import Dodge.Creature.Impulse.Movement
import Dodge.Creature.Impulse.UseItem
import Dodge.Creature.Vocalization
import Dodge.CreatureEffect
import Dodge.Data.World
import Dodge.FloatFunction
import Dodge.RandImpulse
import Dodge.SoundLogic
import Geometry
import qualified IntMapHelp as IM
import LensHelp
import System.Random
impulsiveAIBeforeAfter ::
(World -> Creature -> Creature) ->
(World -> Creature -> Creature) ->
Creature ->
World ->
World
impulsiveAIBeforeAfter startup endup cr w = w' & cWorld . creatures . ix (_crID cr) .~ endup w' cr'
where
w' = g w
(g,cr') = impulsiveAI startup cr w
(g, cr') = impulsiveAI startup cr w
impulsiveAIBefore :: (World -> Creature -> Creature)
-> Creature -> World -> World
impulsiveAIBefore ::
(World -> Creature -> Creature) ->
Creature ->
World ->
World
impulsiveAIBefore f cr w = g w & cWorld . creatures . ix (_crID cr) .~ cr'
where
(g,cr') = impulsiveAI f cr w
(g, cr') = impulsiveAI f cr w
impulsiveAI
:: (World -> Creature -> Creature) -- | internal creature update
-> Creature
-> World
-> (World -> World , Creature)
impulsiveAI ::
(World -> Creature -> Creature) ->
Creature ->
World ->
(World -> World, Creature)
impulsiveAI f cr w = followImpulses w $ f w cr
followThenClearImpulses :: Creature -> World -> World
followThenClearImpulses = impulsiveAIBeforeAfter (const id) (const $ crActionPlan . apImpulse .~ [])
followImpulses :: World -> Creature -> (World -> World, Creature)
followImpulses w cr = foldr f (id, cr) (_apImpulse $ _crActionPlan cr)
where
f imp (theupdate,cr') = first (. theupdate) $ followImpulse cr' w imp
f imp (theupdate, cr') = first (. theupdate) $ followImpulse cr' w imp
followImpulse :: Creature -> World -> Impulse -> (World -> World , Creature)
followImpulse :: Creature -> World -> Impulse -> (World -> World, Creature)
followImpulse cr w imp = case imp of
ImpulseNothing -> (id,cr)
ImpulseNothing -> (id, cr)
RandomImpulse rimp ->
let (newimp,newgen) = runState (doRandImpulse rimp) (_randGen w)
in first ((randGen .~ newgen) .) $ followImpulse cr w newimp
Bark sid -> (soundStart (CrMouth cid) cpos sid Nothing, resetCrVocCoolDown cr)
Move p -> crup $ crMvBy p cr
MoveForward x -> crup $ crMvForward x cr
Turn a -> crup $ creatureTurn a cr
TurnToward p a -> crup $ creatureTurnToward p a cr
TurnTo p -> crup $ creatureTurnTo p cr
ChangePosture post -> crup $ cr & crStance . posture .~ post
UseItem -> (useItem cr, cr)
SwitchToItem i -> crup $ cr & crInvSel .~ InvSel i NoInvSelAction
Melee cid' -> (hitCr cid'
, crMvBy (10 *.* normalizeV (posFromID cid' -.- cpos)) $ cr & crMeleeCooldown .~ 20)
RandomTurn a -> (randGen .~ snd (rr a), creatureTurn (fst $ rr a) cr)
MakeSound sid -> ( soundStart (CrSound (_crID cr)) (_crPos cr) sid Nothing , cr )
DropItem -> undefined
ChangeStrategy strat -> crup $ cr & crActionPlan . apStrategy .~ strat
AddGoal gl -> crup $ cr & crActionPlan . apGoal .:~ gl
ArbitraryImpulseFunction f -> crup $ doWdCrCr f w cr
ArbitraryImpulse f -> followImpulse cr w (doCrWdImp f cr w)
let (newimp, newgen) = runState (doRandImpulse rimp) (_randGen w)
in first ((randGen .~ newgen) .) $ followImpulse cr w newimp
Bark sid -> (soundStart (CrMouth cid) cpos sid Nothing, resetCrVocCoolDown cr)
Move p -> crup $ crMvBy p cr
MoveForward x -> crup $ crMvForward x cr
Turn a -> crup $ creatureTurn a cr
TurnToward p a -> crup $ creatureTurnToward p a cr
TurnTo p -> crup $ creatureTurnTo p cr
ChangePosture post -> crup $ cr & crStance . posture .~ post
UseItem -> (useItem cr, cr)
SwitchToItem i -> crup $ cr & crInvSel .~ InvSel i NoInvSelAction
Melee cid' ->
( hitCr cid'
, crMvBy (10 *.* normalizeV (posFromID cid' -.- cpos)) $ cr & crMeleeCooldown .~ 20
)
RandomTurn a -> (randGen .~ snd (rr a), creatureTurn (fst $ rr a) cr)
MakeSound sid -> (soundStart (CrSound (_crID cr)) (_crPos cr) sid Nothing, cr)
DropItem -> undefined
ChangeStrategy strat -> crup $ cr & crActionPlan . apStrategy .~ strat
AddGoal gl -> crup $ cr & crActionPlan . apGoal .:~ gl
ArbitraryImpulseFunction f -> crup $ doWdCrCr f w cr
ArbitraryImpulse f -> followImpulse cr w (doCrWdImp f cr w)
ArbitraryImpulseEffect f -> (doCrWdWd f cr, cr)
ImpulseUseTargetCID f -> case cr ^? crIntention . targetCr . _Just of
ImpulseUseTargetCID f -> case cr ^? crIntention . targetCr . _Just of
Just tcr -> followImpulse cr w (doIntImp f $ _crID tcr)
_ -> crup cr
_ -> crup cr
ImpulseUseTarget f -> case cr ^? crIntention . targetCr . _Just of
Just tcr -> followImpulse cr w (doCrImp f tcr)
_ -> crup cr
_ -> crup cr
ImpulseUseAheadPos f -> followImpulse cr w (doP2Imp f (_crPos cr +.+ 20 *.* unitVectorAtAngle (_crDir cr)))
MvForward -> crup $ crMvForward speed cr
MvTurnToward p -> crup
$ creatureTurnToward p (turnRad $ safeAngleVV (p -.- cpos) (unitVectorAtAngle cdir)) cr
MvForward -> crup $ crMvForward speed cr
MvTurnToward p ->
crup $
creatureTurnToward p (turnRad $ safeAngleVV (p -.- cpos) (unitVectorAtAngle cdir)) cr
where
crup = (id,)
mvType = _crMvType cr
@@ -93,10 +100,11 @@ followImpulse cr w imp = case imp of
turnRad = doFloatFloat $ _mvTurnRad mvType
cpos = _crPos cr
cdir = _crDir cr
cid = _crID cr
cid = _crID cr
posFromID cid' = _crPos $ _creatures (_cWorld w) IM.! cid'
rr a = randomR (-a,a) $ _randGen w
hitCr i = (cWorld . creatures . ix i . crState . csDamage
.:~ Damage BLUNT 100 cpos (posFromID i) (posFromID i) NoDamageEffect
rr a = randomR (- a, a) $ _randGen w
hitCr i =
( cWorld . creatures . ix i . crState . csDamage
.:~ Damage BLUNT 100 cpos (posFromID i) (posFromID i) NoDamageEffect
)
. soundStart (CrSound cid) cpos hitS Nothing
. soundStart (CrSound cid) cpos hitS Nothing
src/Dodge/Creature/Impulse/Flee.hs
+11 -10
View File
@@ -1,16 +1,17 @@
module Dodge.Creature.Impulse.Flee
where
import Dodge.Data
import Geometry
import FoldableHelp
module Dodge.Creature.Impulse.Flee where
retreatPointForFrom
:: Float -> World -> Creature -> Point2 -> Maybe Point2
retreatPointForFrom d _ cr p
= safeMinimumOn (dist cpos)
$ divideCircle 10 p d
import Dodge.Data.World
import FoldableHelp
import Geometry
retreatPointForFrom ::
Float -> World -> Creature -> Point2 -> Maybe Point2
retreatPointForFrom d _ cr p =
safeMinimumOn (dist cpos) $
divideCircle 10 p d
where
cpos = _crPos cr
-- = head $ sortBy (compare `on` (\p -> dist p ypos < 300)) $ retreatP'' : retreatPs
-- where
-- retreatPs = sortBy (compare `on` dist cpos) $ map f $ nRaysRad 8 400
src/Dodge/Creature/Impulse/Movement.hs
+45 -36
View File
@@ -1,25 +1,30 @@
module Dodge.Creature.Impulse.Movement where
import Dodge.Data
import Control.Lens
import Dodge.Creature.Statistics
import Dodge.Data.World
import Geometry
--import Data.Maybe
--import qualified IntMapHelp as IM
import Control.Lens
{- | Creature attempts to moves under its own steam.
The idea is that this may or may not work, depending on the status of the creature.
For now, though, this cannot fail. -}
crMvBy :: Point2 -- ^ Movement translation vector, will be made relative to creature direction
-> Creature -> Creature
For now, though, this cannot fail.
-}
crMvBy ::
-- | Movement translation vector, will be made relative to creature direction
Point2 ->
Creature ->
Creature
crMvBy p cr = crMvAbsolute (rotateV (_crDir cr) p) cr
crMvAbsolute
:: Point2 -- ^ Movement translation vector
-> Creature
-> Creature
crMvAbsolute p' cr = advanceStepCounter (magV p) cr
& crPos %~ (+.+ p)
& crMvDir .~ argV p
crMvAbsolute ::
-- | Movement translation vector
Point2 ->
Creature ->
Creature
crMvAbsolute p' cr =
advanceStepCounter (magV p) cr
& crPos %~ (+.+ p)
& crMvDir .~ argV p
where
p = strengthFactor (getCrStrength cr) *.* p'
@@ -29,16 +34,18 @@ strengthFactor i
| i < 1 = 0
| otherwise = 0.1 * fromIntegral i
crMvForward
:: Float -- ^ Speed
-> Creature
-> Creature
crMvForward ::
-- | Speed
Float ->
Creature ->
Creature
crMvForward speed = crMvBy (V2 speed 0)
advanceStepCounter
:: Float -- ^ Speed
-> Creature
-> Creature
advanceStepCounter ::
-- | Speed
Float ->
Creature ->
Creature
advanceStepCounter speed = crStance . carriage %~ f
where
f car = case car of
@@ -52,23 +59,25 @@ creatureTurn a = crDir +~ a
creatureTurnTo :: Point2 -> Creature -> Creature
creatureTurnTo p cr
| vToTarg == V2 0 0 = cr -- this should deal with the angleVV error
| otherwise = cr & crDir .~ dirToTarget
| otherwise = cr & crDir .~ dirToTarget
where
vToTarg = p -.- _crPos cr
dirToTarget = argV vToTarg
-- the following is perhaps not ideal because it mixes normalizeAngle with
-- angleVV, but it seems to work
creatureTurnTowardDir
:: Float -- ^ Angle
-> Float -- ^ Turn speed
-> Creature
-> Creature
creatureTurnTowardDir ::
-- | Angle
Float ->
-- | Turn speed
Float ->
Creature ->
Creature
creatureTurnTowardDir a turnSpeed cr
| normalizeAngle (abs (a - cdir)) <= turnSpeed
= cr & crDir .~ dirToTarget
| isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr)
= cr & crDir +~ turnSpeed
| normalizeAngle (abs (a - cdir)) <= turnSpeed =
cr & crDir .~ dirToTarget
| isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) =
cr & crDir +~ turnSpeed
| otherwise = cr & crDir -~ turnSpeed
where
cdir = _crDir cr
@@ -78,14 +87,14 @@ creatureTurnTowardDir a turnSpeed cr
creatureTurnToward :: Point2 -> Float -> Creature -> Creature
creatureTurnToward p turnSpeed cr
| vToTarg == V2 0 0 = cr -- this should deal with the angleVV error
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
= cr & crDir .~ dirToTarget
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed =
cr & crDir .~ dirToTarget
| isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed
| otherwise = cr & crDir -~ turnSpeed
| otherwise = cr & crDir -~ turnSpeed
where
vToTarg = p -.- _crPos cr
dirToTarget = argV vToTarg
{- | Speed modifier of an item when not aiming. -}
-- | Speed modifier of an item when not aiming.
equipSpeed :: Item -> Float
equipSpeed _ = 1
src/Dodge/Creature/Impulse/UseItem.hs
+8 -9
View File
@@ -4,12 +4,11 @@ module Dodge.Creature.Impulse.UseItem (
itemEffect,
) where
--import qualified Data.IntSet as IS
import Control.Lens
import qualified Data.Map.Strict as M
import Data.Maybe
import Dodge.Cuse
import Dodge.Data
import Dodge.Data.World
import Dodge.Euse
import Dodge.HeldUse
import Dodge.Inventory
@@ -29,7 +28,7 @@ useItem cr' w = fromMaybe (f w) $ do
itemEffect :: Creature -> Item -> World -> World
itemEffect cr it w = case it ^. itUse of
RightUse{_rUse = eff, _useMods = usemods} ->
HeldUse{_heldUse = eff, _heldMods = usemods} ->
hammerTest $ tryReload cr it w $ foldr ($) (useHeld eff) (useMod usemods) it cr
LeftUse{} -> doequipmentchange
EquipUse{} -> doequipmentchange
@@ -53,7 +52,7 @@ tryReload cr it w f
| _crID cr == _yourID (_cWorld w) && itNeedsLoading it && _mouseButtons w M.!? SDL.ButtonLeft == Just False =
crToggleReloading cr
| otherwise =
(runIdentity . pointerToItemLocation (_itLocation it) (return . (itUse . useHammer .~ HammerDown)))
(runIdentity . pointerToItemLocation (_itLocation it) (return . (itUse . heldHammer .~ HammerDown)))
. f
itNeedsLoading :: Item -> Bool
@@ -104,8 +103,8 @@ toggleEquipmentAt rbops invid cr w = case rbops ^? opAllocateEquipment of
crpoint = cWorld . creatures . ix (_crID cr)
itmat i = _crInv cr IM.! i
itm = itmat (crSel cr)
onequip itm' = useE ((_eqOnEquip . _eqEq . _itUse) itm') itm'
onremove itm' = useE ((_eqOnRemove . _eqEq . _itUse) itm') itm'
onequip itm' = useE ((_eeOnEquip . _equipEffect . _itUse) itm') itm'
onremove itm' = useE ((_eeOnRemove . _equipEffect . _itUse) itm') itm'
useLeftItem :: Int -> World -> World
useLeftItem cid w
@@ -114,16 +113,16 @@ useLeftItem cid w
| otherwise = fromMaybe w $ do
invid <- _crLeftInvSel cr
itm <- cr ^? crInv . ix invid
f <- cr ^? crInv . ix invid . itUse . lUse
f <- cr ^? crInv . ix invid . itUse . leftUse
return
. (runIdentity . pointerToItemLocation (_itLocation itm) (return . (itUse . useHammer .~ HammerDown)))
. (runIdentity . pointerToItemLocation (_itLocation itm) (return . (itUse . leftHammer .~ HammerDown)))
. useL f itm cr
$ w
where
cr = _creatures (_cWorld w) IM.! cid
itmShouldBeUsed =
isJust (cr ^? crInv . ix (crSel cr) . itUse . cUse)
|| ( isJust (cr ^? crInv . ix (crSel cr) . itUse . eqEq . eqUse)
|| ( isJust (cr ^? crInv . ix (crSel cr) . itUse . equipEffect . eeUse)
&& _crLeftInvSel cr /= Just (crSel cr)
)
src/Dodge/Creature/Inanimate.hs
+26 -21
View File
@@ -2,34 +2,39 @@
{-
Inanimate objects such as lamps, barrels, etc
-}
module Dodge.Creature.Inanimate
( barrel
, explosiveBarrel
, module Dodge.Creature.Lamp
) where
import Dodge.Data
module Dodge.Creature.Inanimate (
barrel,
explosiveBarrel,
module Dodge.Creature.Lamp,
) where
import Dodge.Creature.Lamp
import Dodge.Data.Creature
import Dodge.Default
import qualified IntMapHelp as IM
import LensHelp
barrel :: Creature
barrel = defaultInanimate
{ _crHP = 500
, _crType = Barreloid PlainBarrel
, _crState = defaultState
{_csSpState = Barrel []
barrel =
defaultInanimate
{ _crHP = 500
, _crType = Barreloid PlainBarrel
, _crState =
defaultState
{ _csSpState = Barrel []
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
}
explosiveBarrel :: Creature
explosiveBarrel = defaultInanimate
{ _crHP = 400
, _crType = Barreloid ExplosiveBarrel
, _crState = defaultState
{_csSpState = Barrel []
explosiveBarrel =
defaultInanimate
{ _crHP = 400
, _crType = Barreloid ExplosiveBarrel
, _crState =
defaultState
{ _csSpState = Barrel []
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
}
& crMaterial .~ Crystal
& crMaterial .~ Crystal
src/Dodge/Creature/Lamp.hs
+19 -15
View File
@@ -1,19 +1,23 @@
module Dodge.Creature.Lamp
( lamp
, colorLamp
) where
import Dodge.Data
module Dodge.Creature.Lamp (
lamp,
colorLamp,
) where
import Dodge.Data.Creature
import Dodge.Default
import Geometry.Data
colorLamp
:: Point3 -- color of lamp
-> Float -- height of lamp
-> Creature
colorLamp col h = defaultInanimate
{ _crHP = 100
, _crType = Lampoid h col Nothing
, _crRad = 3
, _crMass = 3
}
colorLamp ::
Point3 -> -- color of lamp
Float -> -- height of lamp
Creature
colorLamp col h =
defaultInanimate
{ _crHP = 100
, _crType = Lampoid h col Nothing
, _crRad = 3
, _crMass = 3
}
lamp :: Float -> Creature
lamp = colorLamp 0.75
src/Dodge/Creature/LauncherCrit.hs
+17 -20
View File
@@ -1,24 +1,21 @@
module Dodge.Creature.LauncherCrit
( launcherCrit
)
where
import Dodge.Data
module Dodge.Creature.LauncherCrit (
launcherCrit,
) where
import Dodge.Item.Held.Launcher
import Control.Lens
import Dodge.Data.Creature
import Dodge.Default
import Dodge.Item.Weapon.Launcher
import qualified IntMapHelp as IM
import Picture
import qualified IntMapHelp as IM
import Control.Lens
launcherCrit :: Creature
launcherCrit = defaultCreature
{ _crInv = IM.fromList [(0,launcher)]
, _crRad = 10
, _crState = defaultState
, _crHP = 300
}
& crType . skinUpper .~ light4 red
& crType . humanoidAI .~ LauncherAI
launcherCrit =
defaultCreature
{ _crInv = IM.fromList [(0, launcher)]
, _crRad = 10
, _crState = defaultState
, _crHP = 300
}
& crType . skinUpper .~ light4 red
& crType . humanoidAI .~ LauncherAI
src/Dodge/Creature/LtAutoCrit.hs
+16 -16
View File
@@ -1,21 +1,21 @@
module Dodge.Creature.LtAutoCrit
( ltAutoCrit
) where
import Dodge.Data
module Dodge.Creature.LtAutoCrit (
ltAutoCrit,
) where
import Control.Lens
import Dodge.Data.Creature
import Dodge.Default
import Dodge.Item.Weapon.BulletGuns
import Dodge.Item.Consumable
import Dodge.Item.Held.Stick
import qualified IntMapHelp as IM
import Picture
import qualified IntMapHelp as IM
import Control.Lens
ltAutoCrit :: Creature
ltAutoCrit = defaultCreature
{ _crInv = IM.fromList [(0,autoPistol),(1,medkit 100)]
, _crRad = 10
, _crHP = 500
}
& crType . humanoidAI .~ LtAutoAI
& crType . skinUpper .~ light4 red
ltAutoCrit =
defaultCreature
{ _crInv = IM.fromList [(0, autoPistol), (1, medkit 100)]
, _crRad = 10
, _crHP = 500
}
& crType . humanoidAI .~ LtAutoAI
& crType . skinUpper .~ light4 red
src/Dodge/Creature/Perception.hs
+105 -90
View File
@@ -1,31 +1,28 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Creature.Perception
( perceptionUpdate
, chaseCritPerceptionUpdate
-- , newSounds
) where
import Dodge.Data
import Dodge.FloatFunction
import Dodge.Creature.Vocalization
import Dodge.Base.Collide
import RandomHelp
--import Dodge.SoundLogic
import Geometry.Vector
--import Geometry.Data
import Geometry.Data
import Sound.Data
--import StrictHelp
module Dodge.Creature.Perception (
perceptionUpdate,
chaseCritPerceptionUpdate,
) where
import Data.Maybe
import Control.Lens
import qualified IntMapHelp as IM
import qualified Data.Map.Strict as M
import Data.Maybe
import Dodge.Base.Collide
import Dodge.Creature.Vocalization
import Dodge.Data.World
import Dodge.FloatFunction
import Geometry.Data
import Geometry.Vector
import qualified IntMapHelp as IM
import RandomHelp
import Sound.Data
perceptionUpdate
:: [Int] -- ^ List of creature ids that may direct attention and awareness
-> World
-> Creature
-> Creature
perceptionUpdate ::
-- | List of creature ids that may direct attention and awareness
[Int] ->
World ->
Creature ->
Creature
perceptionUpdate is w = rememberSounds w . basicAwarenessUpdate . basicAttentionUpdate is w
chaseCritPerceptionUpdate :: [Int] -> World -> Creature -> Creature
@@ -33,47 +30,53 @@ chaseCritPerceptionUpdate is w =
rememberSounds w . chaseCritAwarenessUpdate w . basicAttentionUpdate is w
{- | Update a creatures awareness based upon the creatures' current direction
of attention -} -- TODO delete?
of attention
-} -- TODO delete?
basicAwarenessUpdate :: Creature -> Creature
basicAwarenessUpdate cr = case _cpAttention $ _crPerception cr of
Fixated i -> cr & crPerception . cpAwareness
%~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness)
AttentiveTo is -> cr
& crPerception . cpAwareness
%~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
& maybeBark
Fixated i ->
cr & crPerception . cpAwareness
%~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness)
AttentiveTo is ->
cr
& crPerception . cpAwareness
%~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
& maybeBark
where
oldAwareness = _cpAwareness $ _crPerception cr
newAwareness = (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is) oldAwareness
becomesCognizant = any isCognizant $ IM.unionWith cogRaised oldAwareness newAwareness
thejitter = RandImpulseCircMove 1
--do
--p <- randInCirc 1
--return $ Move p
--do
--p <- randInCirc 1
--return $ Move p
maybeBark
| becomesCognizant = case vocalizationTest cr of
Just sid -> crActionPlan . apAction .~
[ImpulsesList
[[Bark sid]
,[RandomImpulse thejitter]
,[RandomImpulse thejitter]
,[RandomImpulse thejitter]
,[RandomImpulse thejitter]
,[RandomImpulse thejitter]
]
]
Just sid ->
crActionPlan . apAction
.~ [ ImpulsesList
[ [Bark sid]
, [RandomImpulse thejitter]
, [RandomImpulse thejitter]
, [RandomImpulse thejitter]
, [RandomImpulse thejitter]
, [RandomImpulse thejitter]
]
]
Nothing -> id
| otherwise = id
-- TODO fold in randgen update, requires that this is a world to world function
chaseCritAwarenessUpdate :: World -> Creature -> Creature
chaseCritAwarenessUpdate w cr = case _cpAttention $ _crPerception cr of
Fixated i -> cr & crPerception . cpAwareness
%~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness)
AttentiveTo is -> cr
& crPerception . cpAwareness
%~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
& maybeBark
Fixated i ->
cr & crPerception . cpAwareness
%~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness)
AttentiveTo is ->
cr
& crPerception . cpAwareness
%~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is)
& maybeBark
where
oldAwareness = _cpAwareness $ _crPerception cr
newAwareness = (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is) oldAwareness
@@ -85,14 +88,19 @@ chaseCritAwarenessUpdate w cr = case _cpAttention $ _crPerception cr of
-- return $ Move p
maybeBark
| becomesCognizant -- && randBool
&& cr ^? crVocalization . vcCoolDown == Just 0
= let soundid = evalState (takeOne (_vcWarnings (_crVocalization cr))) (_randGen w)
numjits = fst $ randomR (15,25) (_randGen w)
in crActionPlan . apStrategy .~ StrategyActions WarningCry
[ImpulsesList ([Bark soundid]: replicate numjits [RandomImpulse thejitter]++
[[ChangeStrategy $ CloseToMelee 0] ])
, AimAt 0 (_crPos $ _creatures (_cWorld w) IM.! 0)
]
&& cr ^? crVocalization . vcCoolDown == Just 0 =
let soundid = evalState (takeOne (_vcWarnings (_crVocalization cr))) (_randGen w)
numjits = fst $ randomR (15, 25) (_randGen w)
in crActionPlan . apStrategy
.~ StrategyActions
WarningCry
[ ImpulsesList
( [Bark soundid] :
replicate numjits [RandomImpulse thejitter]
++ [[ChangeStrategy $ CloseToMelee 0]]
)
, AimAt 0 (_crPos $ _creatures (_cWorld w) IM.! 0)
]
| otherwise = id
cogRaised :: Awareness -> Awareness -> Awareness
@@ -100,19 +108,18 @@ cogRaised Suspicious{} Cognizant{} = Cognizant 100
cogRaised _ _ = Suspicious 0
isCognizant :: Awareness -> Bool
isCognizant Cognizant {} = True
isCognizant Cognizant{} = True
isCognizant _ = False
combineAwareness :: Awareness -> Awareness -> Awareness
combineAwareness (Suspicious x) (Suspicious y)
| x + y < 5000 = Suspicious $ x + y
| otherwise = Cognizant 1000
| otherwise = Cognizant 1000
combineAwareness (Suspicious x) (Cognizant y) = Cognizant $ min 10000 $ x + y
combineAwareness (Cognizant x) (Suspicious y) = Cognizant $ min 10000 $ x + y
combineAwareness (Cognizant x) (Cognizant y) = Cognizant $ min 10000 $ x + y
combineAwareness (Cognizant x) (Cognizant y) = Cognizant $ min 10000 $ x + y
{- | Decrease awareness level. Returns 'Maybe' value for use with 'IM.mapMaybe'
-}
-- | Decrease awareness level. Returns 'Maybe' value for use with 'IM.mapMaybe'
decreaseAwareness :: Awareness -> Maybe Awareness
decreaseAwareness (Suspicious 0) = Nothing
decreaseAwareness (Suspicious x) = Just $ Suspicious (x - 50)
@@ -120,20 +127,25 @@ decreaseAwareness (Cognizant 0) = Just $ Suspicious 1000
decreaseAwareness (Cognizant x) = Just $ Cognizant $ x - 50
{- | Given a fixed group of creatures, direct attention to those of them that
- are in view. -}
basicAttentionUpdate
:: [Int] -- ^ Creatures that may attract this creature's attention
-> World
-> Creature
-> Creature
basicAttentionUpdate cids w cr = cr & crPerception . cpAttention .~
AttentiveTo (IM.mapMaybe (newExtraAwareness cr w) $ IM.fromList $ zip cids cids)
- are in view.
-}
basicAttentionUpdate ::
-- | Creatures that may attract this creature's attention
[Int] ->
World ->
Creature ->
Creature
basicAttentionUpdate cids w cr =
cr & crPerception . cpAttention
.~ AttentiveTo (IM.mapMaybe (newExtraAwareness cr w) $ IM.fromList $ zip cids cids)
newExtraAwareness
:: Creature -- ^ source creature
-> World
-> Int -- ^ target creature id
-> Maybe Awareness
newExtraAwareness ::
-- | source creature
Creature ->
World ->
-- | target creature id
Int ->
Maybe Awareness
newExtraAwareness cr w cid
| not $ canSeeIndirect (_crID cr) cid w = Nothing
| otherwise = Just . Suspicious $ doFloatFloat (_viFOV vi) ang * doFloatFloat (_viDist vi) d * awakeLevelPerception cr
@@ -141,18 +153,18 @@ newExtraAwareness cr w cid
vi = _cpVision $ _crPerception cr
tpos = _crPos $ _creatures (_cWorld w) IM.! cid
cpos = _crPos cr
ang = angleVV (unitVectorAtAngle (_crDir cr)) (tpos - cpos)
ang = angleVV (unitVectorAtAngle (_crDir cr)) (tpos - cpos)
d = dist tpos cpos
awakeLevelPerception :: Creature -> Float
awakeLevelPerception cr = case _cpVigilance $ _crPerception cr of
Comatose -> 0
Asleep -> 10
Lethargic -> 200
Vigilant -> 500
Overstrung -> 10000
Comatose -> 0
Asleep -> 10
Lethargic -> 200
Vigilant -> 500
Overstrung -> 10000
newSounds :: World -> [(Point2,Float)]
newSounds :: World -> [(Point2, Float)]
newSounds = mapMaybe f . M.elems . _playingSounds
where
f s = case _playStatus $ _soundStatus s of
@@ -160,18 +172,21 @@ newSounds = mapMaybe f . M.elems . _playingSounds
_ -> Nothing
rememberSounds :: World -> Creature -> Creature
rememberSounds w cr = cr
& crMemory . soundsToInvestigate .~ closesounds
& awakeupdate
rememberSounds w cr =
cr
& crMemory . soundsToInvestigate .~ closesounds
& awakeupdate
where
awakeupdate | null closesounds = id
awakeupdate
| null closesounds = id
| otherwise = crPerception . cpVigilance .~ Vigilant
closesounds = map fst (filter (soundIsClose w cr) (newSounds w))
-- TODO work out correct form for sounds passing through walls
soundIsClose :: World -> Creature -> (Point2,Float) -> Bool
soundIsClose w cr (pos,vol) = dist cpos pos < 2000
&& vol > doFloatFloat (_auDist . _cpAudition $ _crPerception cr) (dist pos cpos)
&& hasLOS cpos pos w
soundIsClose :: World -> Creature -> (Point2, Float) -> Bool
soundIsClose w cr (pos, vol) =
dist cpos pos < 2000
&& vol > doFloatFloat (_auDist . _cpAudition $ _crPerception cr) (dist pos cpos)
&& hasLOS cpos pos w
where
cpos = _crPos cr
src/Dodge/Creature/Picture.hs
+115 -93
View File
@@ -1,34 +1,35 @@
--{-# LANGUAGE TupleSections #-}
{- |
Drawing of creatures.
Takes into account damage etc. -}
module Dodge.Creature.Picture
( basicCrPict
, drawCrEquipment
, circLine
, picAtCrPos
, shapeAtCrPos
, picAtCrPosNoRot
-- , basicCrCorpse
, deadScalp
, deadUpperBody
, deadFeet
) where
import Dodge.Data
import Dodge.Creature.HandPos (translateToRightHand,translateToLeftHand)
import Dodge.Creature.Test
import Dodge.Damage
import Dodge.Item.Draw
import Picture
import Geometry
import Shape
import ShapePicture
import qualified Quaternion as Q
Takes into account damage etc.
-}
module Dodge.Creature.Picture (
basicCrPict,
drawCrEquipment,
circLine,
picAtCrPos,
shapeAtCrPos,
picAtCrPosNoRot,
deadScalp,
deadUpperBody,
deadFeet,
) where
import Control.Lens
import Dodge.Creature.HandPos (translateToLeftHand, translateToRightHand)
import Dodge.Creature.Test
import Dodge.Damage
import Dodge.Data.Creature
import Dodge.Item.Draw
import Geometry
import Picture
import qualified Quaternion as Q
import Shape
import ShapePicture
basicCrPict :: Creature -> SPic
basicCrPict cr = drawCrEquipment cr <> (basicCrShape cr , mempty)
basicCrPict cr = drawCrEquipment cr <> (basicCrShape cr, mempty)
drawCrEquipment :: Creature -> SPic
drawCrEquipment cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr)
@@ -39,17 +40,19 @@ shapeAtCrPos sh cr =
, mempty
)
basicCrShape
:: Creature
-> Shape
basicCrShape ::
Creature ->
Shape
basicCrShape cr
| _crCamouflage cr == Invisible = mempty
| otherwise = tr . scaleSH (V3 crsize crsize crsize) $ mconcat
[ --rotdir . _spShape $ drawEquipment cr
rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
, rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
, rotmdir $ colorSH (_skinLower cskin) $ feet cr
]
| otherwise =
tr . scaleSH (V3 crsize crsize crsize) $
mconcat
[ --rotdir . _spShape $ drawEquipment cr
rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr
, rotdir $ colorSH (_skinUpper cskin) $ upperBody cr
, rotmdir $ colorSH (_skinLower cskin) $ feet cr
]
where
cskin = _crType cr
crsize = 0.1 * _crRad cr
@@ -79,18 +82,21 @@ basicCrShape cr
feet :: Creature -> Shape
{-# INLINE feet #-}
feet cr = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> mconcat
[ translateSHf ( f sa) off aFoot
, translateSHf (-f sa) (-off) aFoot
]
Just (Walking sa RightForward) -> mconcat
[ translateSHf (-f sa) off aFoot
, translateSHf ( f sa) (-off) aFoot
]
_ -> mconcat
[ translateSHf 0 off aFoot
, translateSHf 0 (-off) aFoot
]
Just (Walking sa LeftForward) ->
mconcat
[ translateSHf (f sa) off aFoot
, translateSHf (- f sa) (- off) aFoot
]
Just (Walking sa RightForward) ->
mconcat
[ translateSHf (- f sa) off aFoot
, translateSHf (f sa) (- off) aFoot
]
_ ->
mconcat
[ translateSHf 0 off aFoot
, translateSHf 0 (- off) aFoot
]
where
aFoot :: Shape
aFoot = upperPrismPoly 10 $ polyCirc 3 4
@@ -101,18 +107,21 @@ feet cr = case cr ^? crStance . carriage of
deadFeet :: Creature -> Shape
{-# INLINE deadFeet #-}
deadFeet cr = case cr ^? crStance . carriage of
Just (Walking sa LeftForward) -> mconcat
[ translateSHf ( f sa) off aFoot
, translateSHf (-f sa) (-off) aFoot
]
Just (Walking sa RightForward) -> mconcat
[ translateSHf (-f sa) off aFoot
, translateSHf ( f sa) (-off) aFoot
]
_ -> mconcat
[ translateSHf 0 off aFoot
, translateSHf 0 (-off) aFoot
]
Just (Walking sa LeftForward) ->
mconcat
[ translateSHf (f sa) off aFoot
, translateSHf (- f sa) (- off) aFoot
]
Just (Walking sa RightForward) ->
mconcat
[ translateSHf (- f sa) off aFoot
, translateSHf (f sa) (- off) aFoot
]
_ ->
mconcat
[ translateSHf 0 off aFoot
, translateSHf 0 (- off) aFoot
]
where
aFoot :: Shape
aFoot = upperPrismPoly 3 $ polyCirc 3 4
@@ -122,23 +131,27 @@ deadFeet cr = case cr ^? crStance . carriage of
arms :: Creature -> Shape
{-# INLINE arms #-}
arms cr = fst $ translateToRightHand cr aHand
<> translateToLeftHand cr aHand
--arms cr
-- | oneH cr = shoulderSH . translateSHf 11 (-3) . rotateSH (-0.5) $ scaleSH (V3 1 1.5 1) aHand
-- | twists cr = shoulderSH . translateSHf 0 5 . rotateSH (-1) $ mconcat
-- [ translateSHf 12 4 aHand
-- , translateSHf 4 (-10) aHand
-- ]
-- | twoFlat cr = waistSH $ translateSHf 4 8 aHand
-- <> translateSHf 4 (-8) aHand
-- | otherwise = case cr ^? crStance . carriage of
-- Just (Walking sa LeftForward) -> waistSH $ translateSHf (-f sa) (-off) aHand
-- Just (Walking sa RightForward) -> waistSH $ translateSHf (-f sa) off aHand
-- _ -> emptySH
arms cr =
fst $
translateToRightHand cr aHand
<> translateToLeftHand cr aHand
where
--arms cr
-- | oneH cr = shoulderSH . translateSHf 11 (-3) . rotateSH (-0.5) $ scaleSH (V3 1 1.5 1) aHand
-- | twists cr = shoulderSH . translateSHf 0 5 . rotateSH (-1) $ mconcat
-- [ translateSHf 12 4 aHand
-- , translateSHf 4 (-10) aHand
-- ]
-- | twoFlat cr = waistSH $ translateSHf 4 8 aHand
-- <> translateSHf 4 (-8) aHand
-- | otherwise = case cr ^? crStance . carriage of
-- Just (Walking sa LeftForward) -> waistSH $ translateSHf (-f sa) (-off) aHand
-- Just (Walking sa RightForward) -> waistSH $ translateSHf (-f sa) off aHand
-- _ -> emptySH
aHand :: SPic
aHand = noPic $ translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4
-- off = 8
-- sLen = _strideLength $ _crStance cr
-- f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
@@ -149,14 +162,17 @@ deadScalp cr = deadRot cr . translateSHz 10 . scalp $ cr
deadRot :: Creature -> Shape -> Shape
deadRot cr = overPosSH (Q.rotateToZ d)
where
d = maybe (V3 1 0 0) (addZ 0 . unitVectorAtAngle . subtract (_crDir cr+pi))
(damageDirection . _csDamage $ _crState cr)
d =
maybe
(V3 1 0 0)
(addZ 0 . unitVectorAtAngle . subtract (_crDir cr + pi))
(damageDirection . _csDamage $ _crState cr)
scalp :: Creature -> Shape
{-# INLINE scalp #-}
scalp cr
| twists cr = translateSHf 0 5 . rotateSH (-1) $ translateSHf (negate 2.5) 0.25 fhead
| oneH cr = rotateSH 0.5 $ translateSHf 2.5 0 fhead
| oneH cr = rotateSH 0.5 $ translateSHf 2.5 0 fhead
| otherwise = translateSHf 2.5 0 fhead
where
fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 $ polyCirc 4 5
@@ -169,18 +185,23 @@ scalp cr
torso :: Creature -> Shape
{-# INLINE torso #-}
torso cr
| oneH cr = rotateSH 0.5 $ mconcat
[ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder
, translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
]
| twists cr = translateSHf 0 5 . rotateSH (-1) $ mconcat
[ rotateSH (negate 0.2) . translateSHf 2 3 . rotateSH (negate 0.4) $ aShoulder
, rotateSH (negate 0.2) . translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
]
| otherwise = mconcat
[ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder
, translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
]
| oneH cr =
rotateSH 0.5 $
mconcat
[ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder
, translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
]
| twists cr =
translateSHf 0 5 . rotateSH (-1) $
mconcat
[ rotateSH (negate 0.2) . translateSHf 2 3 . rotateSH (negate 0.4) $ aShoulder
, rotateSH (negate 0.2) . translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
]
| otherwise =
mconcat
[ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder
, translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
]
where
--aShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPoly 10 $ polyCirc 3 crad
aShoulder = scaleSH (V3 10 10 1) baseShoulder
@@ -195,17 +216,18 @@ baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalf 10
upperBody :: Creature -> Shape
{-# INLINE upperBody #-}
--upperBody col cr = colorSH (light4 col) $ mconcat
upperBody cr = mconcat
[ arms cr
, shoulderSH $ torso cr
]
upperBody cr =
mconcat
[ arms cr
, shoulderSH $ torso cr
]
shoulderSH :: Shape -> Shape
shoulderSH = translateSHz 20
--waistSH :: Shape -> Shape
--waistSH = translateSHz 10
--drawAwakeLevel
-- :: Creature
-- -> Picture
@@ -218,12 +240,13 @@ shoulderSH = translateSHz 20
drawEquipment :: Creature -> SPic
{-# INLINE drawEquipment #-}
drawEquipment cr = foldMap (itemEquipPict cr) (_crInv cr)
--drawEquipment cr = foldMap f (_crInv cr)
-- where
-- f itm = _itEquipPict itm cr itm
circLine :: Float -> Picture
circLine x = line [V2 0 0,V2 x 0]
circLine x = line [V2 0 0, V2 x 0]
picAtCrPos :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-}
@@ -232,4 +255,3 @@ picAtCrPos thePic cr = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic
picAtCrPosNoRot :: Picture -> Creature -> SPic
--{-# INLINE picAtCrPos #-}
picAtCrPosNoRot thePic cr = (,) emptySH $ uncurryV translate (_crPos cr) thePic
src/Dodge/Creature/Picture/Awareness.hs
+25 -20
View File
@@ -1,25 +1,30 @@
module Dodge.Creature.Picture.Awareness where
import Dodge.Data
import Dodge.Clock
import Picture
import Geometry
import qualified Data.Vector as V
import Dodge.Clock
import Dodge.Data.World
import Geometry
import Picture
creatureDisplayText :: World -> Creature -> Picture
creatureDisplayText w cr = setLayer DebugLayer
. setDepth 20
. translate x y
. color white
. rotate (0.5 * pi)
-- . rotate (argV v - 0.5 * pi)
. scale theScale theScale
. stackText
$ clockCycle 25 (V.fromList
[ \cr' -> [crDisplayVigilance cr']
, \cr' -> [crDisplayAwareness cr']
]
) w cr
creatureDisplayText w cr =
setLayer DebugLayer
. setDepth 20
. translate x y
. color white
. rotate (0.5 * pi)
-- . rotate (argV v - 0.5 * pi)
. scale theScale theScale
. stackText
$ clockCycle
25
( V.fromList
[ \cr' -> [crDisplayVigilance cr']
, \cr' -> [crDisplayAwareness cr']
]
)
w
cr
where
campos = _cameraViewFrom (_cWorld w)
theScale = 0.15 / _cameraZoom (_cWorld w)
@@ -30,12 +35,12 @@ creatureDisplayText w cr = setLayer DebugLayer
crDisplayAwareness :: Creature -> String
crDisplayAwareness cr
| isSuspicious = "?"
| isCognizant = "!"
| otherwise = "."
| isCognizant = "!"
| otherwise = "."
where
imAwarenesses = _cpAwareness (_crPerception cr)
isSuspicious = any f imAwarenesses && not (null imAwarenesses)
isCognizant = any g imAwarenesses && not (null imAwarenesses)
isCognizant = any g imAwarenesses && not (null imAwarenesses)
f (Suspicious _) = True
f _ = False
g (Cognizant _) = True
src/Dodge/Creature/PistolCrit.hs
+16 -18
View File
@@ -1,23 +1,21 @@
module Dodge.Creature.PistolCrit
( pistolCrit
) where
import Dodge.Data
module Dodge.Creature.PistolCrit (
pistolCrit,
) where
import Control.Lens
import Dodge.Data.Creature
import Dodge.Default
import Dodge.Item.Weapon.BulletGuns
import Dodge.Item.Consumable
import Dodge.Item.Held.Stick
import qualified IntMapHelp as IM
import Picture
import qualified IntMapHelp as IM
import Control.Lens
pistolCrit :: Creature
pistolCrit = defaultCreature
{ _crInv = IM.fromList [(0,pistol),(1,medkit 100)]
, _crRad = 10
, _crHP = 500
}
& crType . humanoidAI .~ PistolAI
& crType . skinUpper .~ light4 red
pistolCrit =
defaultCreature
{ _crInv = IM.fromList [(0, pistol), (1, medkit 100)]
, _crRad = 10
, _crHP = 500
}
& crType . humanoidAI .~ PistolAI
& crType . skinUpper .~ light4 red
src/Dodge/Creature/ReaderUpdate.hs
+108 -86
View File
@@ -1,31 +1,32 @@
{- | Functions updating a creature in a Reader World environment -}
module Dodge.Creature.ReaderUpdate
( doStrategyActions
, setTargetMv
, targetYouWhenCognizant
, overrideMeleeCloseTarget
, watchUpdateStrat
, reloadOverride
, overrideInternal
, searchIfDamaged
, goToTarget
, flockACC
, chaseCritMv
, setMvPos
, setViewPos
) where
-- | Functions updating a creature in a Reader World environment
module Dodge.Creature.ReaderUpdate (
doStrategyActions,
setTargetMv,
targetYouWhenCognizant,
overrideMeleeCloseTarget,
watchUpdateStrat,
reloadOverride,
overrideInternal,
searchIfDamaged,
goToTarget,
flockACC,
chaseCritMv,
setMvPos,
setViewPos,
) where
import Control.Applicative
import Control.Lens
import Data.Bifunctor
import Data.Maybe
import Dodge.Base
import Dodge.Creature.Volition
import Dodge.Data.CreatureEffect
import Dodge.Data.World
import Dodge.Zoning.Creature
import FoldableHelp
import Dodge.Data
import Dodge.Creature.Volition
import Dodge.Base
import Geometry
import qualified IntMapHelp as IM
import Control.Lens
import Control.Applicative
import Data.Maybe
import Data.Bifunctor
overrideMeleeCloseTarget :: Creature -> Creature
overrideMeleeCloseTarget cr = maybe cr (tryMeleeAttack cr) (_targetCr $ _crIntention cr)
@@ -34,8 +35,8 @@ tryMeleeAttack :: Creature -> Creature -> Creature
tryMeleeAttack cr tcr
| _crMeleeCooldown cr == 0
&& dist (_crPos tcr) cpos < _crRad cr + _crRad tcr + 5
&& abs (_crDir cr - argV (_crPos tcr -.- cpos)) < pi/4
= cr & crActionPlan . apImpulse .~ [Melee $ _crID tcr]
&& abs (_crDir cr - argV (_crPos tcr -.- cpos)) < pi / 4 =
cr & crActionPlan . apImpulse .~ [Melee $ _crID tcr]
| otherwise = cr
where
cpos = _crPos cr
@@ -49,8 +50,10 @@ setMvPos w cr = cr & crIntention . mvToPoint .~ mpos
if hasLOSIndirect (_crPos cr) tpos w
then Just tpos
else Nothing
mpos = mtpos
<|> _mvToPoint int
mpos =
mtpos
<|> _mvToPoint int
-- <|> listToMaybe (_soundsToInvestigate $ _crMemory cr)
setViewPos :: Creature -> Creature
@@ -58,12 +61,17 @@ setViewPos cr = cr & crIntention . viewPoint %~ (<|> mpos)
where
mpos = listToMaybe (_soundsToInvestigate $ _crMemory cr)
setTargetMv :: (World -> Creature -> Maybe Creature) -- ^ Function for determining target
-> World -> Creature -> Creature
setTargetMv targFunc w cr = maybe
cr
(\ctarg -> cr & crIntention . mvToPoint ?~ _crPos ctarg)
(targFunc w cr)
setTargetMv ::
-- | Function for determining target
(World -> Creature -> Maybe Creature) ->
World ->
Creature ->
Creature
setTargetMv targFunc w cr =
maybe
cr
(\ctarg -> cr & crIntention . mvToPoint ?~ _crPos ctarg)
(targFunc w cr)
-- ugly
flockACC :: World -> Creature -> Creature
@@ -72,30 +80,35 @@ flockACC w cr = case cr ^? crIntention . targetCr . _Just of
Just tcr ->
let tpos = _crPos tcr
cpos = _crPos cr
isFarACC cr' = _crGroup cr' == _crGroup cr
&& _crID cr' /= _crID cr
&& dist (_crPos cr') tpos > dist cpos tpos
macr = safeMinimumOn (dist cpos . _crPos)
. filter isFarACC
$ crsNearCirc cpos 50 w
in case macr of
Nothing -> cr
isFarACC cr' =
_crGroup cr' == _crGroup cr
&& _crID cr' /= _crID cr
&& dist (_crPos cr') tpos > dist cpos tpos
macr =
safeMinimumOn (dist cpos . _crPos)
. filter isFarACC
$ crsNearCirc cpos 50 w
in case macr of
Nothing -> cr
Just acr ->
let r = _crRad acr + _crRad cr + 10
horDir = normalizeV (vNormal (cpos -.- tpos))
horShift = if isLHS tpos cpos (_crPos acr)
then r *.* horDir
else negate r *.* horDir
in cr & crIntention . mvToPoint ?~ tpos +.+ horShift
horShift =
if isLHS tpos cpos (_crPos acr)
then r *.* horDir
else negate r *.* horDir
in cr & crIntention . mvToPoint ?~ tpos +.+ horShift
chaseCritMv :: World -> Creature -> Creature
chaseCritMv w cr = case _apStrategy (_crActionPlan cr) of
StrategyActions _ _ -> cr
WarningCry -> cr
_ -> case cr ^? crIntention . mvToPoint . _Just of
Just p | dist (_crPos cr) p > _crRad cr -> cr & crActionPlan . apAction .~ [PathTo p]
| otherwise -> cr & crActionPlan . apAction .~ [bfsThenReturn 500]
& crIntention . mvToPoint .~ Nothing
Just p
| dist (_crPos cr) p > _crRad cr -> cr & crActionPlan . apAction .~ [PathTo p]
| otherwise ->
cr & crActionPlan . apAction .~ [bfsThenReturn 500]
& crIntention . mvToPoint .~ Nothing
_ -> viewTarget w cr
goToTarget :: World -> Creature -> Creature
@@ -105,20 +118,23 @@ goToTarget w cr =
_ -> viewTarget w cr
lookAroundSelf :: Action
lookAroundSelf = UseSelf CrTurnAround -- $ \cr -> TurnToPoint (_crPos cr -.- 10 *.* unitVectorAtAngle (_crDir cr))
lookAroundSelf = UseSelf CrTurnAround
viewTarget :: World -> Creature -> Creature
viewTarget w cr = do
case cr ^? crIntention . viewPoint . _Just of
Just p | hasLOSIndirect p (_crPos cr) w -> cr'
& crActionPlan . apAction %~ replaceNullWith
(TurnToPoint p
`DoActionThen` 40 `WaitThen` lookAroundSelf
`DoActionThen` 20 `WaitThen` lookAroundSelf
)
Just p
| hasLOSIndirect p (_crPos cr) w ->
cr'
& crActionPlan . apAction
%~ replaceNullWith
( TurnToPoint p
`DoActionThen` 40 `WaitThen` lookAroundSelf
`DoActionThen` 20 `WaitThen` lookAroundSelf
)
& crIntention . viewPoint .~ Nothing
| otherwise -> cr' & crActionPlan . apAction %~ replaceNullWith (PathTo p)
Nothing -> cr-- & crPerception . crAwakeLevel .~ Lethargic
| otherwise -> cr' & crActionPlan . apAction %~ replaceNullWith (PathTo p)
Nothing -> cr -- & crPerception . crAwakeLevel .~ Lethargic
where
cr' = cr & crPerception . cpVigilance .~ Vigilant
@@ -128,22 +144,25 @@ replaceNullWith _ xs = xs
doStrategyActions :: Creature -> Creature
doStrategyActions cr = case cr ^? crActionPlan . apStrategy of
Just (StrategyActions strat acs) -> cr
& crActionPlan . apAction .~ acs
& crActionPlan . apStrategy .~ strat
Just (StrategyActions strat acs) ->
cr
& crActionPlan . apAction .~ acs
& crActionPlan . apStrategy .~ strat
_ -> cr
reloadOverride :: Creature -> Creature
reloadOverride cr
| cr ^? crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded == Just 0
&& cr ^. crStance . posture == Aiming
= cr & crActionPlan . apStrategy .~ StrategyActions Reload reloadActions
&& cr ^. crStance . posture == Aiming =
cr & crActionPlan . apStrategy .~ StrategyActions Reload reloadActions
| otherwise = cr
where
reloadActions =
[ holsterWeapon
, 1 `WaitThen`
DoActionWhileInterrupt NoAction (WdCrBlfromCrBl CrIsReloading)
, 1
`WaitThen` DoActionWhileInterrupt
NoAction
(WdCrBlfromCrBl CrIsReloading)
(DoImpulses [ChangeStrategy WatchAndWait])
]
@@ -152,42 +171,47 @@ overrideInternal test update cr
| test cr = update cr
| otherwise = cr
watchUpdateStrat
:: [ (World -> Creature -> Bool, World -> Creature -> Strategy) ]
-> World
-> Creature
-> Creature
watchUpdateStrat ::
[(World -> Creature -> Bool, World -> Creature -> Strategy)] ->
World ->
Creature ->
Creature
watchUpdateStrat fs w cr = case cr ^? crActionPlan . apStrategy of
Just WatchAndWait -> cr
& crActionPlan . apStrategy .~ listGuard (map (first uncurry) fs, \_ _ -> WatchAndWait) (w, cr) w cr
Just WatchAndWait ->
cr
& crActionPlan . apStrategy .~ listGuard (map (first uncurry) fs, \_ _ -> WatchAndWait) (w, cr) w cr
_ -> cr
listGuard :: ([(a -> Bool, b)] , b) -> a -> b
listGuard ( (test,y):ps, z ) x
listGuard :: ([(a -> Bool, b)], b) -> a -> b
listGuard ((test, y) : ps, z) x
| test x = y
| otherwise = listGuard (ps, z) x
listGuard (_,z) _ = z
listGuard (_, z) _ = z
targetYouWhenCognizant :: World -> Creature -> Creature
targetYouWhenCognizant w cr = case cr ^? crPerception . cpAwareness . ix 0 of
-- so this caused a space leak: be careful with ?~
-- consider changing targeted creature to be just an index
Just (Cognizant _) -> _creatures (_cWorld w) IM.! 0 `seq` cr & crIntention . targetCr ?~ _creatures (_cWorld w) IM.! 0
_ -> cr & crIntention . targetCr .~ Nothing
-- so this caused a space leak: be careful with ?~
-- consider changing targeted creature to be just an index
Just (Cognizant _) -> _creatures (_cWorld w) IM.! 0 `seq` cr & crIntention . targetCr ?~ _creatures (_cWorld w) IM.! 0
_ -> cr & crIntention . targetCr .~ Nothing
searchIfDamaged :: Creature -> Creature
searchIfDamaged cr
| _crPastDamage cr > 0 = case _apStrategy (_crActionPlan cr) of
WatchAndWait -> cr & crPerception . cpVigilance .~ Vigilant
& crActionPlan . apStrategy .~ StrategyActions LookAround
[TurnToPoint (_crPos cr -.- unitVectorAtAngle (_crDir cr))
`DoActionThen` 40 `WaitThen` bfsThenReturn 500
]
WatchAndWait ->
cr & crPerception . cpVigilance .~ Vigilant
& crActionPlan . apStrategy
.~ StrategyActions
LookAround
[ TurnToPoint (_crPos cr -.- unitVectorAtAngle (_crDir cr))
`DoActionThen` 40 `WaitThen` bfsThenReturn 500
]
_ -> cr
| otherwise = cr
bfsThenReturn :: Int -> Action
bfsThenReturn t = ArbitraryAction (CrWdBFSThenReturn t)
-- theaction
-- where
-- theaction cr w = fromMaybe NoAction $ do
@@ -195,5 +219,3 @@ bfsThenReturn t = ArbitraryAction (CrWdBFSThenReturn t)
-- let as = take 20 $ map PathTo $ bfsNodePoints n w
-- return $ DoReplicate t $
-- foldr DoActionThen NoAction as
src/Dodge/Creature/SentinelAI.hs
+82 -69
View File
@@ -1,39 +1,44 @@
module Dodge.Creature.SentinelAI
( sentinelAI
, sentinelFireType
, sentinelExtraWatchUpdate
) where
import Dodge.Data
module Dodge.Creature.SentinelAI (
sentinelAI,
sentinelFireType,
sentinelExtraWatchUpdate,
) where
import Control.Lens
import Data.Maybe
import Dodge.Creature.Action
import Dodge.Creature.ChainUpdates
import Dodge.Creature.Test
import Dodge.Creature.Volition
import Dodge.Creature.Perception
import Dodge.Creature.ReaderUpdate
import Dodge.Creature.Strategy
import Dodge.Creature.Action
import Dodge.Creature.Perception
import Dodge.Creature.Test
import Dodge.Creature.Volition
import Dodge.Data.CreatureEffect
import Dodge.Data.World
import Geometry.Data
import Data.Maybe
import Control.Lens
sentinelAI :: World -> Creature -> Creature
sentinelAI w = reloadOverride .
sentinelExtraWatchUpdate
[ (crHasTargetLOS
, \ _ cr -> StrategyActions (ShootAt (fromJust $ tcid cr))
[ DoActionIf
(WdCrNegate $ WdCrBlfromCrBl CrIsAiming)
(drawWeapon `DoActionThen` (50 `WaitThen` NoAction))
`DoActionThen` lostest
`DoActionWhile` advanceShoot
`DoActionThen` 75
`DoReplicate` advanceShoot
`DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
, AimAt { _targetID = fromJust $ tcid cr , _targetSeenAt = V2 0 0 }
]
)
]
w
sentinelAI w =
reloadOverride
. sentinelExtraWatchUpdate
[
( crHasTargetLOS
, \_ cr ->
StrategyActions
(ShootAt (fromJust $ tcid cr))
[ DoActionIf
(WdCrNegate $ WdCrBlfromCrBl CrIsAiming)
(drawWeapon `DoActionThen` (50 `WaitThen` NoAction))
`DoActionThen` lostest
`DoActionWhile` advanceShoot
`DoActionThen` 75
`DoReplicate` advanceShoot
`DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
, AimAt{_targetID = fromJust $ tcid cr, _targetSeenAt = V2 0 0}
]
)
]
w
where
advanceShoot = DoImpulses [UseItem, MoveForward 3]
tcid cr = _crID <$> _targetCr (_crIntention cr)
@@ -42,50 +47,58 @@ sentinelAI w = reloadOverride .
--chainCreatureUpdates :: [World -> Creature -> Creature] -> World -> Creature -> Creature
--chainCreatureUpdates ls w cr = foldr (\f -> f w) cr ls
sentinelFireType :: (Int -> Action) -> World -> Creature -> Creature
sentinelFireType f = chainCreatureUpdates
[ performActions
, watchUpdateStrat
[ (crHasTargetLOS, \_ _ -> StrategyActions (ShootAt 0)
[ drawwp `DoActionThen` f 0 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
, aiming
sentinelFireType f =
chainCreatureUpdates
[ performActions
, watchUpdateStrat
[
( crHasTargetLOS
, \_ _ ->
StrategyActions
(ShootAt 0)
[ drawwp `DoActionThen` f 0 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
, aiming
]
)
, (const crAwayFromPost, const goToPostStrat)
]
)
, (const crAwayFromPost, const goToPostStrat)
]
, perceptionUpdate [0]
-- , Left $ perceptionUp 0
, const doStrategyActions
, const reloadOverride
, targetYouWhenCognizant
, const $ overrideInternal
(\cr -> crHasTarget cr && crStratConMatches (GetTo (V2 0 0)) cr)
(crActionPlan . apStrategy .~ WatchAndWait)
]
, perceptionUpdate [0]
, -- , Left $ perceptionUp 0
const doStrategyActions
, const reloadOverride
, targetYouWhenCognizant
, const $
overrideInternal
(\cr -> crHasTarget cr && crStratConMatches (GetTo (V2 0 0)) cr)
(crActionPlan . apStrategy .~ WatchAndWait)
]
where
drawwp = DoActionIfElse NoAction (WdCrBlfromCrBl CrIsAiming) (DoActionThen drawWeapon (WaitThen 50 NoAction))
aiming = AimAt
{ _targetID = 0
, _targetSeenAt = V2 0 0 -- hack
}
aiming =
AimAt
{ _targetID = 0
, _targetSeenAt = V2 0 0 -- hack
}
sentinelExtraWatchUpdate
:: [(World -> Creature -> Bool , World -> Creature -> Strategy)]
-> World
-> Creature
-> Creature
sentinelExtraWatchUpdate xs = chainCreatureUpdates
[ performActions
, watchUpdateStrat
( xs ++ [(const crAwayFromPost, const goToPostStrat)] )
, perceptionUpdate [0]
, const doStrategyActions
, targetYouWhenCognizant
, const $ overrideInternal
(\cr -> crHasTarget cr && crStratConMatches (GetTo (V2 0 0)) cr)
(crActionPlan . apStrategy .~ WatchAndWait)
]
sentinelExtraWatchUpdate ::
[(World -> Creature -> Bool, World -> Creature -> Strategy)] ->
World ->
Creature ->
Creature
sentinelExtraWatchUpdate xs =
chainCreatureUpdates
[ performActions
, watchUpdateStrat
(xs ++ [(const crAwayFromPost, const goToPostStrat)])
, perceptionUpdate [0]
, const doStrategyActions
, targetYouWhenCognizant
, const $
overrideInternal
(\cr -> crHasTarget cr && crStratConMatches (GetTo (V2 0 0)) cr)
(crActionPlan . apStrategy .~ WatchAndWait)
]
--shootAtAdvance :: Int -> [Action]
--shootAtAdvance tcid =
src/Dodge/Creature/SetTarget.hs
+10 -10
View File
@@ -1,15 +1,15 @@
{- | Deals with setting a target for creatures -}
-- | Deals with setting a target for creatures
module Dodge.Creature.SetTarget where
import Dodge.Data
import Control.Lens
import Dodge.Data.World
import qualified IntMapHelp as IM
{- | Assumes that you are id 0: if creature is cognizant of you, sets you as target -}
targetYouWhenCognizant
:: World
-> Creature
-> Creature
targetYouWhenCognizant w cr = case cr ^? crPerception . cpAwareness . ix 0 of
Just (Cognizant _) -> cr & crIntention . targetCr ?~ _creatures (_cWorld w) IM.! 0
_ -> cr & crIntention . targetCr .~ Nothing
-- | Assumes that you are id 0: if creature is cognizant of you, sets you as target
targetYouWhenCognizant ::
World ->
Creature ->
Creature
targetYouWhenCognizant w cr = case cr ^? crPerception . cpAwareness . ix 0 of
Just (Cognizant _) -> cr & crIntention . targetCr ?~ _creatures (_cWorld w) IM.! 0
_ -> cr & crIntention . targetCr .~ Nothing
src/Dodge/Creature/SpreadGunCrit.hs
+16 -16
View File
@@ -1,21 +1,21 @@
module Dodge.Creature.SpreadGunCrit
( spreadGunCrit
) where
import Dodge.Data
module Dodge.Creature.SpreadGunCrit (
spreadGunCrit,
) where
import Control.Lens
import Dodge.Data.Creature
import Dodge.Default
import Dodge.Item.Weapon.BulletGuns
import Dodge.Item.Consumable
import Dodge.Item.Held.Stick
import qualified IntMapHelp as IM
import Picture
import qualified IntMapHelp as IM
import Control.Lens
spreadGunCrit :: Creature
spreadGunCrit = defaultCreature
{ _crInv = IM.fromList [(0,bangStick 6),(1,medkit 100)]
, _crRad = 10
, _crHP = 500
}
& crType . humanoidAI .~ SpreadGunAI
& crType . skinUpper .~ light4 red
spreadGunCrit =
defaultCreature
{ _crInv = IM.fromList [(0, bangStick 6), (1, medkit 100)]
, _crRad = 10
, _crHP = 500
}
& crType . humanoidAI .~ SpreadGunAI
& crType . skinUpper .~ light4 red
src/Dodge/Creature/State.hs
+182 -140
View File
@@ -1,99 +1,113 @@
module Dodge.Creature.State
( stateUpdate
, doDamage
) where
import Dodge.Corpse.Make
import Dodge.Data
import Dodge.Targeting
import Dodge.ItEffect
import Dodge.Euse
import Dodge.EnergyBall
import Dodge.Damage
import Dodge.Hammer
import Dodge.Reloading
import Dodge.Prop.Gib
module Dodge.Creature.State (
stateUpdate,
doDamage,
) where
import Dodge.Base
import Dodge.Creature.State.WalkCycle
import Dodge.Creature.Impulse.Movement
import Dodge.Creature.Damage
import Dodge.LightSource.Torch
import Dodge.SoundLogic
import RandomHelp
import Dodge.Corpse.Make
import Dodge.Creature.Action
import Dodge.Creature.Damage
import Dodge.Creature.Impulse.Movement
import Dodge.Creature.State.WalkCycle
import Dodge.Damage
import Dodge.Data.World
import Dodge.EnergyBall
import Dodge.Euse
import Dodge.Hammer
import Dodge.ItEffect
import Dodge.LightSource.Torch
import Dodge.Prop.Gib
import Dodge.Reloading
import Dodge.SoundLogic
import Dodge.Targeting
import Geometry
import Picture
import Shape
import ShapePicture
import qualified IntMapHelp as IM
import LensHelp
import Picture
import RandomHelp
import Shape
import ShapePicture
foldCr :: [Creature -> World -> World]
-> Creature -> World -> World
foldCr ::
[Creature -> World -> World] ->
Creature ->
World ->
World
--foldCr xs cr w = foldr ($ cr) w xs
foldCr xs cr w = foldr f w xs
where
f g w' = case w' ^? cWorld . creatures . ix (_crID cr) of
Just cr' -> g cr' w'
Nothing -> w'
Nothing -> w'
-- | this seems to work, but I am not sure about the ordering:
-- previously, the movement was updated before the ai in order to correctly set the oldpos.
-- This should be made more sensible: should the movement side effects apply to
-- the creature before or after it has moved?
-- at what point invSideEffects is applied wrt to when the creature moves
-- may affect whether the shield moves correctly
{- | this seems to work, but I am not sure about the ordering:
previously, the movement was updated before the ai in order to correctly set the oldpos.
This should be made more sensible: should the movement side effects apply to
the creature before or after it has moved?
at what point invSideEffects is applied wrt to when the creature moves
may affect whether the shield moves correctly
-}
stateUpdate :: (Creature -> World -> World) -> Creature -> World -> World
stateUpdate f = foldCr
[ equipmentEffects
, invSideEff
, upInv -- upInv must be called before invSideEff 22.05.23
, movementSideEff
, f
, internalUpdate
, clearDamage -- these three
, checkDeath -- must be in
, doDamage -- this order 22/06/05
]
stateUpdate f =
foldCr
[ equipmentEffects
, invSideEff
, upInv -- upInv must be called before invSideEff 22.05.23
, movementSideEff
, f
, internalUpdate
, clearDamage -- these three
, checkDeath -- must be in
, doDamage -- this order 22/06/05
]
checkDeath :: Creature -> World -> World
checkDeath cr w
| _crHP cr > 0 = w
| otherwise = w
-- & creatures . at (_crID cr) .~ Nothing
& dropByState cr
& removecr
& stopSoundFrom (CrWeaponSound (_crID cr) 0)
& corpseOrGib cr
| otherwise =
w
-- & creatures . at (_crID cr) .~ Nothing
& dropByState cr
& removecr
& stopSoundFrom (CrWeaponSound (_crID cr) 0)
& corpseOrGib cr
where
removecr
| _crID cr == 0 = (cWorld . creatures . ix (_crID cr) . crType .~ NonDrawnCreature)
. (cWorld . creatures . ix (_crID cr) . crHP .~ 0)
-- hack to get around player creature being killed but left with more than 0 hp
| otherwise = cWorld . creatures . at (_crID cr) .~ Nothing
| _crID cr == 0 =
(cWorld . creatures . ix (_crID cr) . crType .~ NonDrawnCreature)
. (cWorld . creatures . ix (_crID cr) . crHP .~ 0)
-- hack to get around player creature being killed but left with more than 0 hp
| otherwise = cWorld . creatures . at (_crID cr) .~ Nothing
corpseOrGib :: Creature -> World -> World
corpseOrGib cr w = case maxDamageType (_csDamage (_crState cr)) of
Just (FLAMING,_) -> w & plNew (cWorld . corpses) cpID (thecorpse & cpSPic %~ scorchSPic)
Just (ELECTRICAL,_) -> w & plNew (cWorld . corpses) cpID thecorpse
Just (POISONDAM,_) -> w & plNew (cWorld . corpses) cpID (thecorpse & cpSPic %~ poisonSPic)
_ | _crPastDamage cr > 200 -> w & addCrGibs cr
& bloodPuddleAt cpos
& bloodPuddleAt cpos
& bloodPuddleAt cpos
_ -> w
& bloodPuddleAt cpos
& bloodPuddleAt cpos
& plNew (cWorld . corpses) cpID thecorpse
Just (FLAMING, _) -> w & plNew (cWorld . corpses) cpID (thecorpse & cpSPic %~ scorchSPic)
Just (ELECTRICAL, _) -> w & plNew (cWorld . corpses) cpID thecorpse
Just (POISONDAM, _) -> w & plNew (cWorld . corpses) cpID (thecorpse & cpSPic %~ poisonSPic)
_
| _crPastDamage cr > 200 ->
w & addCrGibs cr
& bloodPuddleAt cpos
& bloodPuddleAt cpos
& bloodPuddleAt cpos
_ ->
w
& bloodPuddleAt cpos
& bloodPuddleAt cpos
& plNew (cWorld . corpses) cpID thecorpse
where
cpos = _crPos cr
thecorpse = makeDefaultCorpse cr
scorchSPic :: SPic -> SPic
scorchSPic = over _1 $
overColSH (mixColors 0.9 0.1 black . normalizeColor)
scorchSPic =
over _1 $
overColSH (mixColors 0.9 0.1 black . normalizeColor)
poisonSPic :: SPic -> SPic
poisonSPic = over _1 $
overColSH (mixColors 0.5 0.5 green . normalizeColor)
poisonSPic =
over _1 $
overColSH (mixColors 0.5 0.5 green . normalizeColor)
--scorchSPic :: World -> SPic -> SPic
--scorchSPic w sp = evalState (scorchSPic' sp) (_randGen w)
@@ -103,22 +117,27 @@ poisonSPic = over _1 $
---- (return . mixColorsLinear 0.9 0.1 black)
bloodPuddleAt :: Point2 -> World -> World
bloodPuddleAt p w = w
& snd . plNewID (cWorld . decorations)
(color (dark $ dark red) . setDepth 01 . uncurryV translate (p +.+ q) $ circleSolid 10)
& randGen .~ g
bloodPuddleAt p w =
w
& snd
. plNewID
(cWorld . decorations)
(color (dark $ dark red) . setDepth 01 . uncurryV translate (p +.+ q) $ circleSolid 10)
& randGen .~ g
where
(q,g) = randInCirc 10 & runState $ _randGen w
(q, g) = randInCirc 10 & runState $ _randGen w
internalUpdate :: Creature -> World -> World
internalUpdate cr = cWorld . creatures . ix (_crID cr) %~
( (crHammerPosition %~ moveHammerUp)
. stepReloading
. updateMovement
)
internalUpdate cr =
cWorld . creatures . ix (_crID cr)
%~ ( (crHammerPosition %~ moveHammerUp)
. stepReloading
. updateMovement
)
-- | Drop items according to the creature state.
-- TODO make sure this doesn't mess up any ItemPosition
{- | Drop items according to the creature state.
TODO make sure this doesn't mess up any ItemPosition
-}
dropByState :: Creature -> World -> World
dropByState cr w = foldr (dropItem cr) w $ case cr ^. crState . csDropsOnDeath of
DropAll -> IM.keys $ _crInv cr
@@ -126,79 +145,91 @@ dropByState cr w = foldr (dropItem cr) w $ case cr ^. crState . csDropsOnDeath o
DropAmount n -> take n $ evalState (shuffle $ IM.keys $ _crInv cr) (_randGen w)
clearDamage :: Creature -> World -> World
clearDamage cr w = w
& cWorld . creatures . ix (_crID cr) . crState . csDamage .~ []
clearDamage cr w =
w
& cWorld . creatures . ix (_crID cr) . crState . csDamage .~ []
doDamage :: Creature -> World -> World
doDamage cr w = w
& applyPastDamages cr
& applyCreatureDamage dams cr
doDamage cr w =
w
& applyPastDamages cr
& applyCreatureDamage dams cr
where
dams = _csDamage $ _crState cr
-- TODO generalise shake to arbitrary damage amounts
applyPastDamages :: Creature -> World -> World
applyPastDamages cr w
| _crPastDamage cr > 200 = let (p,g) = runState (randInCirc 3) (_randGen w)
in w & cWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 100))
& randGen .~ g
| _crPastDamage cr > 20 = let (p,g) = runState (randInCirc 2) (_randGen w)
in w & cWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 10))
& randGen .~ g
| _crPastDamage cr > 0 = let (p,g) = runState (randInCirc 1) (_randGen w)
in w & cWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 1))
& randGen .~ g
| _crPastDamage cr > 200 =
let (p, g) = runState (randInCirc 3) (_randGen w)
in w & cWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 100))
& randGen .~ g
| _crPastDamage cr > 20 =
let (p, g) = runState (randInCirc 2) (_randGen w)
in w & cWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 10))
& randGen .~ g
| _crPastDamage cr > 0 =
let (p, g) = runState (randInCirc 1) (_randGen w)
in w & cWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 1))
& randGen .~ g
| otherwise = w
movementSideEff :: Creature -> World -> World
movementSideEff cr w
| hasJetPack = case cr ^? crStance . carriage of
Just (Boosting v) -> w
& randGen .~ g
& makeFlamelet
(oldPos +.+ (_crRad cr + 3) *.* unitVectorAtAngle (_crDir cr + pi))
20
(momentum +.+ 1 *.* rotateV randDir (vInverse v))
1
20
_ -> w
Just (Boosting v) ->
w
& randGen .~ g
& makeFlamelet
(oldPos +.+ (_crRad cr + 3) *.* unitVectorAtAngle (_crDir cr + pi))
20
(momentum +.+ 1 *.* rotateV randDir (vInverse v))
1
20
_ -> w
| otherwise = footstepSideEffect cr w
where
hasJetPack = any (\it -> it ^? itType . iyBase == Just (EQUIP JETPACK)) $ _crInv cr
oldPos = _crOldPos cr
momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr)
momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum'
| otherwise = momentum'
momentum''
| magV momentum' > 3 = 3 *.* normalizeV momentum'
| otherwise = momentum'
momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng
(randDir,g) = randomR (-0.5,0.5) $ _randGen w
(randAng,_) = randomR (0,2*pi) $ _randGen w
(randDir, g) = randomR (-0.5, 0.5) $ _randGen w
(randAng, _) = randomR (0, 2 * pi) $ _randGen w
useUpdate :: ItemUse -> ItemUse
useUpdate = (useHammer %~ moveHammerUp)
. (useDelay . warmTime %~ decreaseToZero)
. (useDelay . rateTime %~ decreaseToZero)
useUpdate =
(heldHammer %~ moveHammerUp)
. (heldDelay . warmTime %~ decreaseToZero)
. (heldDelay . rateTime %~ decreaseToZero)
useEquipment :: Creature -> Int -> World -> World
useEquipment cr i = useE (_eqUse (_eqEq $ _itUse itm)) itm cr
useEquipment cr i = useE (_eeUse (_equipEffect $ _itUse itm)) itm cr
where
itm = _crInv cr IM.! i
-- a map updating all inventory items
upInv :: Creature -> World -> World
upInv cr = cWorld . creatures . ix (_crID cr) . crInv %~ IM.mapWithKey (itemUpdate cr)
-- a loop going over equipped items
equipmentEffects :: Creature -> World -> World
equipmentEffects cr = flip (foldr $ useEquipment cr) (IM.keys $ _crInvEquipped cr)
-- a loop going over all inventory items
invSideEff :: Creature -> World -> World
invSideEff cr w = weaponReloadSounds cr $ IM.foldrWithKey f w (_crInv cr)
where
f i it w' = itemInvSideEffect cr it
$ doItemTargeting i cr w' & maybe id (\g -> doInvEffect g it cr) (it ^? itEffect . ieInv)
f i it w' =
itemInvSideEffect cr it $
doItemTargeting i cr w' & maybe id (\g -> doInvEffect g it cr) (it ^? itEffect . ieInv)
itemInvSideEffect :: Creature -> Item -> World -> World
itemInvSideEffect cr it
| hastorchattach = createAttachLight cr it
| otherwise = id
| otherwise = id
where
hastorchattach = it ^? itType . iyModules . ix ModHeldAttach == Just ATTACHTORCH && _itIsHeld it
@@ -210,43 +241,53 @@ createAttachLight cr it = createTorchLightOffset cr it attachoff
itemUpdate :: Creature -> Int -> Item -> Item
itemUpdate cr i
| i == crSel cr = baseupdate True
| otherwise = baseupdate False
| otherwise = baseupdate False
where
baseupdate bool = updateAutoRecharge . (itUse %~ useUpdate)
. (itLocation .~ InInv (_crID cr) i)
. (itIsHeld .~ bool)
baseupdate bool =
updateAutoRecharge . (itUse %~ useUpdate)
. (itLocation .~ InInv (_crID cr) i)
. (itIsHeld .~ bool)
updateAutoRecharge :: Item -> Item
updateAutoRecharge it = case it ^? itUse . leftConsumption of
Just (AutoRecharging l m t p)
| l < m && p <= 0 -> it & itUse . leftConsumption .~ AutoRecharging (l+1) m t t
| l < m && p <= 0 -> it & itUse . leftConsumption .~ AutoRecharging (l + 1) m t t
| l < m -> it & itUse . leftConsumption . arProgress -~ 1
_ -> it
doItemTargeting :: Int -> Creature -> World -> World
doItemTargeting invid cr w = case cr ^? crInv . ix invid . itTargeting of
Nothing -> w
Just NoTargeting -> w
Just t -> let (w',t') = updateTargeting (_tgUpdate t) (_crInv cr IM.! invid) cr w t
in w' & cWorld . creatures . ix (_crID cr) . crInv . ix invid . itTargeting .~ t'
Just t ->
let (w', t') = updateTargeting (_tgUpdate t) (_crInv cr IM.! invid) cr w t
in w' & cWorld . creatures . ix (_crID cr) . crInv . ix invid . itTargeting .~ t'
weaponReloadSounds :: Creature -> World -> World
weaponReloadSounds cr w = case cr ^? crInvSel . iselAction of
Just ReloadAction{_reloadAction = la} -> soundContinue
(CrReloadSound cid) (_crPos cr) (_actionSound la) (Just 1) w
Just ReloadAction{_reloadAction = la} ->
soundContinue
(CrReloadSound cid)
(_crPos cr)
(_actionSound la)
(Just 1)
w
_ -> w
-- PassiveReload stype | Just (_laReloadTime am) == am ^? laTransfer . transferTime
-- -> soundContinue (CrReloadSound 0) (_crPos cr) stype Nothing w
-- PassiveReload _ -> w
-- ActiveClear | am ^? laTransfer . transferTime == Just 0 -> stopSoundFrom (CrReloadSound cid) w
-- ActiveClear | _laTransfer am == NoTransfer -> w
-- ActiveClear -> soundContinue (CrReloadSound cid) (_crPos cr) reloadS (Just 1) w
-- ActivePartial{} | am ^? laTransfer . transferTime == Just 0 -> stopSoundFrom (CrReloadSound cid) w
-- ActivePartial{} | _laTransfer am == NoTransfer -> w
-- ActivePartial{} -> soundContinue (CrReloadSound cid) (_crPos cr) reloadS (Just 1) w
-- Just ChargeableAmmo {} -> w
-- Just NoConsumption {} -> w
-- Just ItemItselfConsumable {} -> w
-- Nothing -> w
where
-- PassiveReload stype | Just (_laReloadTime am) == am ^? laTransfer . transferTime
-- -> soundContinue (CrReloadSound 0) (_crPos cr) stype Nothing w
-- PassiveReload _ -> w
-- ActiveClear | am ^? laTransfer . transferTime == Just 0 -> stopSoundFrom (CrReloadSound cid) w
-- ActiveClear | _laTransfer am == NoTransfer -> w
-- ActiveClear -> soundContinue (CrReloadSound cid) (_crPos cr) reloadS (Just 1) w
-- ActivePartial{} | am ^? laTransfer . transferTime == Just 0 -> stopSoundFrom (CrReloadSound cid) w
-- ActivePartial{} | _laTransfer am == NoTransfer -> w
-- ActivePartial{} -> soundContinue (CrReloadSound cid) (_crPos cr) reloadS (Just 1) w
-- Just ChargeableAmmo {} -> w
-- Just NoConsumption {} -> w
-- Just ItemItselfConsumable {} -> w
-- Nothing -> w
cid = _crID cr
updateMovement :: Creature -> Creature
@@ -255,12 +296,13 @@ updateMovement cr
| otherwise = updateWalkCycle cr
where
momentum' = 0.98 *.* (_crPos cr -.- _crOldPos cr)
momentum'' | magV momentum' > 1 = 1 *.* normalizeV momentum'
| otherwise = momentum'
momentum''
| magV momentum' > 1 = 1 *.* normalizeV momentum'
| otherwise = momentum'
momentum = momentum''
isFrictionless :: Creature -> Bool
isFrictionless cr = case cr ^? crStance . carriage of
Just (Boosting _) -> True
Just Floating -> True
_ -> False
Just Floating -> True
_ -> False
src/Dodge/Creature/State/WalkCycle.hs
+8 -9
View File
@@ -1,15 +1,14 @@
module Dodge.Creature.State.WalkCycle
( updateWalkCycle
, footstepSideEffect
)
where
import Dodge.Data
module Dodge.Creature.State.WalkCycle (
updateWalkCycle,
footstepSideEffect,
) where
import Control.Lens
import Dodge.Data.World
import Dodge.SoundLogic
import Geometry.Data
import Sound.Data
import Control.Lens
updateWalkCycle :: Creature -> Creature
updateWalkCycle cr = case cr ^? crStance . carriage of
Just (Walking x ff) | x > maxStride -> cr & crStance . carriage .~ Walking 0 (normalGait ff)
@@ -35,7 +34,7 @@ makeFootstepSound currentStride maxStride ff p
| currentStride > maxStride = soundMultiFrom footor p (chooseFootSound ff) Nothing
| otherwise = id
where
footor = [FootstepSound 0,FootstepSound 1]
footor = [FootstepSound 0, FootstepSound 1]
chooseFootSound :: FootForward -> SoundID
chooseFootSound LeftForward = foot1S
src/Dodge/Creature/Statistics.hs
+2 -3
View File
@@ -3,11 +3,10 @@ module Dodge.Creature.Statistics (
getCrDexterity,
) where
--import Data.Strict.IntMap.Autogen.Merge.Strict
import Data.IntMap.Merge.Strict
import Data.Maybe
import Dodge.Creature.Test
import Dodge.Data
import Dodge.Data.Creature
import qualified IntMapHelp as IM
import LensHelp
@@ -38,5 +37,5 @@ crCurrentEquipment cr =
strFromHeldItem :: Creature -> Int
strFromHeldItem cr
| _posture (_crStance cr) == Aiming || crIsReloading cr =
negate $ fromMaybe 0 $ cr ^? crInv . ix (crSel cr) . itUse . useAim . aimWeight
negate $ fromMaybe 0 $ cr ^? crInv . ix (crSel cr) . itUse . heldAim . aimWeight
| otherwise = 0
src/Dodge/Creature/Strategy.hs
+16 -14
View File
@@ -1,25 +1,27 @@
module Dodge.Creature.Strategy
( goToPostStrat
)
where
import Dodge.Data
import Dodge.Creature.Test
import Dodge.Creature.Volition
module Dodge.Creature.Strategy (
goToPostStrat,
) where
import Data.List
import Dodge.Creature.Test
import Dodge.Creature.Volition
import Dodge.Data.Creature
goToPostStrat :: Creature -> Strategy
goToPostStrat cr = case find sentinelGoal $ _apGoal $ _crActionPlan cr of
Just (SentinelAt p _) -> StrategyActions (GetTo p)
[DoActionThen (WaitThen 150 holsterIfAiming)
$ DoActionThen (PathTo p)
NoAction
-- $ DoImpulses [ChangeStrategy WatchAndWait]
]
Just (SentinelAt p _) ->
StrategyActions
(GetTo p)
[ DoActionThen (WaitThen 150 holsterIfAiming) $
DoActionThen
(PathTo p)
NoAction
-- $ DoImpulses [ChangeStrategy WatchAndWait]
]
_ -> WatchAndWait
where
sentinelGoal (SentinelAt _ _) = True
sentinelGoal _ = False
holsterIfAiming
| crIsAiming cr = holsterWeapon
| otherwise = NoAction
| otherwise = NoAction
src/Dodge/Creature/SwarmCrit.hs
+17 -18
View File
@@ -1,23 +1,24 @@
module Dodge.Creature.SwarmCrit
( swarmCrit
) where
import Dodge.Data
module Dodge.Creature.SwarmCrit (
swarmCrit,
) where
import Control.Lens
import Dodge.Data.Creature
import Dodge.Default
import Picture
import Control.Lens
swarmCrit :: Creature
swarmCrit = defaultCreature
{ _crHP = 1
, _crRad = 2
, _crMass = 2
, _crCorpse = MakeDefaultCorpse
, _crFaction = ColorFaction yellow
, _crMeleeCooldown = 0
}
& crType . skinUpper .~ light4 yellow
& crType . humanoidAI .~ SwarmAI
swarmCrit =
defaultCreature
{ _crHP = 1
, _crRad = 2
, _crMass = 2
, _crCorpse = MakeDefaultCorpse
, _crFaction = ColorFaction yellow
, _crMeleeCooldown = 0
}
& crType . skinUpper .~ light4 yellow
& crType . humanoidAI .~ SwarmAI
--swarmCritMoveFunc :: Creature -> Point2 -> Creature -> Point2
--swarmCritMoveFunc tcr cenp cr
@@ -25,5 +26,3 @@ swarmCrit = defaultCreature
-- where
-- cpos = _crPos cr
-- ypos = _crPos tcr
src/Dodge/Creature/Test.hs
+37 -36
View File
@@ -5,38 +5,35 @@ Note that if there is a world parameter,
the creature NEED NOT be the same as the creature with that id in the world,
in fact a creature with that id need not exist.
-}
module Dodge.Creature.Test
( crIsAiming
, crIsReloading
, crIsArmouredFrom
, oneH
, twists
, twoFlat
, crWeaponReady
, crInAimStance
, crNearPoint
, isAnimate
, crCanShoot
, crHasTargetLOS
, crAwayFromPost
, crHasTarget
, crStratConMatches
, crSafeDistFromTarg
)
where
import Dodge.Data
import Dodge.Base.Collide
import Geometry
--import SameConstr
module Dodge.Creature.Test (
crIsAiming,
crIsReloading,
crIsArmouredFrom,
oneH,
twists,
twoFlat,
crWeaponReady,
crInAimStance,
crNearPoint,
isAnimate,
crCanShoot,
crHasTargetLOS,
crAwayFromPost,
crHasTarget,
crStratConMatches,
crSafeDistFromTarg,
) where
import Control.Lens
import Data.List (find)
import Data.Maybe
--import qualified IntMapHelp as IM
import Control.Lens
import Dodge.Base.Collide
import Dodge.Data.World
import Geometry
crIsReloading :: Creature -> Bool
crIsReloading cr = case cr ^? crInvSel . iselAction of
Just ReloadAction {} -> True
Just ReloadAction{} -> True
_ -> False
crWeaponReady :: Creature -> Bool
@@ -45,7 +42,7 @@ crWeaponReady cr = fromMaybe False $ do
return (_laLoaded ic > 0 && _laPrimed ic)
crCanSeeCr :: Creature -> (World, Creature) -> Bool
crCanSeeCr tcr (w,cr) = hasLOS (_crPos cr) (_crPos tcr) w
crCanSeeCr tcr (w, cr) = hasLOS (_crPos cr) (_crPos tcr) w
crIsAiming :: Creature -> Bool
crIsAiming cr = _posture (_crStance cr) == Aiming
@@ -55,7 +52,7 @@ crHasTarget cr = isJust $ cr ^? crIntention . targetCr . _Just
crHasTargetLOS :: World -> Creature -> Bool
crHasTargetLOS w cr = case cr ^? crIntention . targetCr . _Just of
Just i -> crCanSeeCr i (w,cr)
Just i -> crCanSeeCr i (w, cr)
Nothing -> False
crSafeDistFromTarg :: Float -> Creature -> Bool
@@ -65,7 +62,8 @@ crSafeDistFromTarg d cr = case cr ^? crIntention . targetCr . _Just of
crStratConMatches :: Strategy -> Creature -> Bool
crStratConMatches strat cr = strat == _apStrategy (_crActionPlan cr)
-- this equality check might be slow...
-- this equality check might be slow...
crAwayFromPost :: Creature -> Bool
crAwayFromPost cr = case find sentinelGoal . _apGoal $ _crActionPlan cr of
@@ -79,8 +77,9 @@ crCanShoot :: Creature -> Bool
crCanShoot cr = crIsAiming cr && crWeaponReady cr
crInAimStance :: AimStance -> Creature -> Bool
crInAimStance as cr = crIsAiming cr
&& cr ^? crInv . ix (crSel cr) . itUse . useAim . aimStance == Just as
crInAimStance as cr =
crIsAiming cr
&& cr ^? crInv . ix (crSel cr) . itUse . heldAim . aimStance == Just as
oneH :: Creature -> Bool
oneH = crInAimStance OneHand
@@ -101,11 +100,13 @@ hasFrontArmour :: Point2 -> Creature -> Bool
hasFrontArmour p cr = fromMaybe False $ do
invid <- cr ^? crEquipment . ix OnChest
ittype <- cr ^? crInv . ix invid . itType . iyBase
return $ EQUIP FRONTARMOUR == ittype
&& p /= _crOldPos cr
&& angleVV (unitVectorAtAngle (_crDir cr + frontarmdirection)) (p -.- _crOldPos cr) < pi/2
-- even though angleVV can generate NaN, the comparison seems to deal with it
return $
EQUIP FRONTARMOUR == ittype
&& p /= _crOldPos cr
&& angleVV (unitVectorAtAngle (_crDir cr + frontarmdirection)) (p -.- _crOldPos cr) < pi / 2
where
-- even though angleVV can generate NaN, the comparison seems to deal with it
frontarmdirection
| crInAimStance OneHand cr = 0.5
| crInAimStance TwoHandTwist cr = negate 1
@@ -124,4 +125,4 @@ isAnimate :: Creature -> Bool
{-# INLINE isAnimate #-}
isAnimate cr = case _crActionPlan cr of
Inanimate -> False
_ -> True
_ -> True
src/Dodge/Creature/Update.hs
+19 -16
View File
@@ -1,29 +1,32 @@
module Dodge.Creature.Update where
import Dodge.Data
import Dodge.Creature.State
import Dodge.Creature.Impulse
import Dodge.Creature.ChainUpdates
import Dodge.Lampoid
import Dodge.Humanoid
import Dodge.Turretoid
import Dodge.Barreloid
import LensHelp
import Dodge.Barreloid
import Dodge.Creature.ChainUpdates
import Dodge.Creature.Impulse
import Dodge.Creature.State
import Dodge.Data.World
import Dodge.Humanoid
import Dodge.Lampoid
import Dodge.Turretoid
import LensHelp
import System.Random
updateCreature :: Creature -> World -> World
updateCreature cr = case _crType cr of
Lampoid{} -> updateLampoid cr
Humanoid{} -> updateHumanoid cr
Lampoid{} -> updateLampoid cr
Humanoid{} -> updateHumanoid cr
Turretoid{} -> updateTurretoid cr
Barreloid{} -> updateBarreloid cr
NonDrawnCreature -> id
-- bit of a hack to get new random generators after each creature's update
defaultImpulsive :: [World -> Creature -> Creature]
-> Creature -> World -> World
defaultImpulsive ::
[World -> Creature -> Creature] ->
Creature ->
World ->
World
defaultImpulsive = fmap (fmap updateRandGen) . stateUpdate . impulsiveAIBefore . chainCreatureUpdates
where
updateRandGen w = let (_,g) = randomR (0,1::Int) (_randGen w)
in w & randGen .~ g
updateRandGen w =
let (_, g) = randomR (0, 1 :: Int) (_randGen w)
in w & randGen .~ g
src/Dodge/Creature/Vocalization.hs
+4 -4
View File
@@ -1,15 +1,15 @@
module Dodge.Creature.Vocalization where
import Dodge.Data
import Sound.Data
import Control.Lens
import Dodge.Data.Creature
import Sound.Data
vocalizationTest :: Creature -> Maybe SoundID
vocalizationTest cr = case cr ^? crVocalization . vcCoolDown of
Just 0 -> Just $ _vcSound $ _crVocalization cr
_ -> Nothing
_ -> Nothing
resetCrVocCoolDown :: Creature -> Creature
resetCrVocCoolDown cr = case cr ^? crVocalization . vcMaxCoolDown of
Just i -> cr & crVocalization . vcCoolDown .~ i
Just i -> cr & crVocalization . vcCoolDown .~ i
Nothing -> cr
src/Dodge/Creature/Volition.hs
+17 -16
View File
@@ -1,12 +1,13 @@
{- | Not a good name, perhaps: internal creature actions. -}
module Dodge.Creature.Volition
( holsterWeapon
, drawWeapon
, shootTillEmpty
-- , fleeFrom
, shootFirstMiss
) where
import Dodge.Data
-- | Not a good name, perhaps: internal creature actions.
module Dodge.Creature.Volition (
holsterWeapon,
drawWeapon,
shootTillEmpty,
shootFirstMiss,
) where
import Dodge.Data.Creature
import Dodge.Data.CreatureEffect
import Dodge.SoundLogic.LoadSound
import Geometry
@@ -14,11 +15,11 @@ holsterWeapon, drawWeapon :: Action
holsterWeapon = DoImpulses [ChangePosture AtEase, MakeSound whiteNoiseFadeOutS]
drawWeapon = DoImpulses [ChangePosture Aiming, MakeSound whiteNoiseFadeInS]
shootTillEmpty :: Action
--shootTillEmpty = (crCanShoot `DoActionWhile` DoImpulses [UseItem])
shootTillEmpty = (WdCrBlfromCrBl CrCanShoot `DoActionWhile` DoImpulses [UseItem])
`DoActionThen` 20 `WaitThen` holsterWeapon
shootTillEmpty =
(WdCrBlfromCrBl CrCanShoot `DoActionWhile` DoImpulses [UseItem])
`DoActionThen` 20 `WaitThen` holsterWeapon
--advanceShoot :: Int -> Action
--advanceShoot tcid = lostest `DoActionWhile`
@@ -31,7 +32,7 @@ shootTillEmpty = (WdCrBlfromCrBl CrCanShoot `DoActionWhile` DoImpulses [UseItem]
shootFirstMiss :: Action
shootFirstMiss =
LeadTarget (V2 30 50) `DoActionThen`
DoImpulses [UseItem] `DoActionThen`
(WdCrBlfromCrBl CrCanShoot `DoActionWhile` DoActions [LeadTarget (V2 0 0),DoImpulses [UseItem]])
`DoActionThen` 20 `WaitThen` holsterWeapon
LeadTarget (V2 30 50)
`DoActionThen` DoImpulses [UseItem]
`DoActionThen` (WdCrBlfromCrBl CrCanShoot `DoActionWhile` DoActions [LeadTarget (V2 0 0), DoImpulses [UseItem]])
`DoActionThen` 20 `WaitThen` holsterWeapon
src/Dodge/Creature/YourControl.hs
+39 -35
View File
@@ -1,49 +1,53 @@
module Dodge.Creature.YourControl
( yourControl
) where
import Dodge.Data
import Dodge.LightSource
module Dodge.Creature.YourControl (
yourControl,
) where
import qualified Data.Map.Strict as M
import Dodge.Base.Coordinate
import Dodge.Creature.Impulse.Movement
import Dodge.Creature.Test
import Dodge.Update.UsingInput
import Dodge.Data.World
import Dodge.InputFocus
import Dodge.LightSource
import Dodge.Update.UsingInput
import Geometry
import LensHelp
import qualified SDL
import qualified Data.Map.Strict as M
{- | The AI equivalent for your control. -}
-- | The AI equivalent for your control.
yourControl :: Creature -> World -> World
yourControl cr w
| inTermFocus w = dimCreatureLight cr w & updateUsingInput
| otherwise = dimCreatureLight cr w
& cWorld . creatures . ix (_crID cr) %~
(wasdWithAiming w (_mvSpeed $ _crMvType cr) . mouseActionsCr (_mouseButtons w))
& updateUsingInput
| otherwise =
dimCreatureLight cr w
& cWorld . creatures . ix (_crID cr)
%~ (wasdWithAiming w (_mvSpeed $ _crMvType cr) . mouseActionsCr (_mouseButtons w))
& updateUsingInput
dimCreatureLight :: Creature -> World -> World
dimCreatureLight cr = cWorld . tempLightSources .:~ tlsTimeRadColPos 1 300 0.1 (addZ 100 $ _crPos cr)
-- note the order of operation, setting the posture first--this prevents the twist fire bug
{- | Turn key presses into creature movement. -}
wasdWithAiming
:: World
-> Float -- ^ Base speed
-> Creature
-> Creature
-- | Turn key presses into creature movement.
wasdWithAiming ::
World ->
-- | Base speed
Float ->
Creature ->
Creature
wasdWithAiming w speed cr
| isAiming = addAnyTwist $ set crDir mouseDir $ theMovement cr
| crIsReloading cr && SDL.ButtonRight `M.member` _mouseButtons w
= addAnyTwist $ set crDir (mouseDir + anytwist) $ theMovement cr
| isAiming = addAnyTwist $ set crDir mouseDir $ theMovement cr
| crIsReloading cr && SDL.ButtonRight `M.member` _mouseButtons w =
addAnyTwist $ set crDir (mouseDir + anytwist) $ theMovement cr
| otherwise = theMovement $ theTurn $ removeTwist cr
where
twistamount = 1.6
removeTwist cr' = cr'
& crDir +~ _crTwist cr'
& crTwist .~ 0
anytwist = case cr ^? crInv . ix (crSel cr) . itUse . useAim . aimStance of
removeTwist cr' =
cr'
& crDir +~ _crTwist cr'
& crTwist .~ 0
anytwist = case cr ^? crInv . ix (crSel cr) . itUse . heldAim . aimStance of
Just TwoHandTwist -> twistamount * pi
_ -> 0
addAnyTwist = crTwist .~ anytwist
@@ -53,7 +57,7 @@ wasdWithAiming w speed cr
theTurn cr' = creatureTurnTowardDir (_crMvDir cr') 0.2 cr'
movDir = wasdDir w
dir = _cameraRot (_cWorld w) + argV movDir
movAbs = rotateV (_cameraRot (_cWorld w)) $ normalizeV movDir
movAbs = rotateV (_cameraRot (_cWorld w)) $ normalizeV movDir
isAiming = _posture (_crStance cr) == Aiming
mouseDir = case cr ^? crInv . ix (crSel cr) . itScope . scopePos of
Just _ -> argV $ mouseWorldPos w -.- _crPos cr
@@ -61,20 +65,20 @@ wasdWithAiming w speed cr
wasdM :: SDL.Scancode -> Point2
wasdM scancode = case scancode of
SDL.ScancodeW -> V2 0 1
SDL.ScancodeS -> V2 0 (-1)
SDL.ScancodeD -> V2 1 0
SDL.ScancodeA -> V2 (-1) 0
_ -> V2 0 0
SDL.ScancodeW -> V2 0 1
SDL.ScancodeS -> V2 0 (-1)
SDL.ScancodeD -> V2 1 0
SDL.ScancodeA -> V2 (-1) 0
_ -> V2 0 0
wasdDir :: World -> Point2
wasdDir = foldr ((+.+) . wasdM) (V2 0 0) . _keys
{- | Set posture according to mouse presses. -}
-- | Set posture according to mouse presses.
mouseActionsCr :: M.Map SDL.MouseButton Bool -> Creature -> Creature
mouseActionsCr pkeys cr
| rbPressed && cr ^?! crInvSel . iselAction == NoInvSelAction
= cr & crStance . posture .~ Aiming
| rbPressed && cr ^?! crInvSel . iselAction == NoInvSelAction =
cr & crStance . posture .~ Aiming
| otherwise = cr & crStance . posture .~ AtEase
where
rbPressed = SDL.ButtonRight `M.member` pkeys
src/Dodge/CreatureEffect.hs
+31 -26
View File
@@ -1,12 +1,13 @@
module Dodge.CreatureEffect where
import Dodge.Creature.Test
import Dodge.Data
import Geometry
import Dodge.Base.Collide
import Dodge.Path
import qualified IntMapHelp as IM
import Data.Maybe
import Dodge.Base.Collide
import Dodge.Creature.Test
import Dodge.Data.CreatureEffect
import Dodge.Data.World
import Dodge.Path
import Geometry
import qualified IntMapHelp as IM
doWdCrCr :: WdCrCr -> World -> Creature -> Creature
doWdCrCr ce = case ce of
@@ -38,8 +39,11 @@ doWdCrBl wcb = case wcb of
WdCrTrue -> const $ const True
WdCrBlfromCrBl cb -> \_ cr -> doCrBl cb cr
WdCrNegate wcb' -> \w -> not . doWdCrBl wcb' w
WdCrLOSTarget -> \w cr -> maybe False (\cid -> canSee (_crID cr) cid w)
(_crID <$> _targetCr (_crIntention cr))
WdCrLOSTarget -> \w cr ->
maybe
False
(\cid -> canSee (_crID cr) cid w)
(_crID <$> _targetCr (_crIntention cr))
WdCrSafeDistFromTarget x -> \_ -> crSafeDistFromTarg x -- currently ignores walls etc
doCrBl :: CrBl -> Creature -> Bool
@@ -74,21 +78,22 @@ doCrWdAc cw = case cw of
CrWdBFSThenReturn t -> \cr w -> fromMaybe NoAction $ do
n <- walkableNodeNear w (_crPos cr)
let as = take 20 $ map PathTo $ bfsNodePoints n w
return $ DoReplicate t $
foldr DoActionThen NoAction as
return $
DoReplicate t $
foldr DoActionThen NoAction as
ChooseMovementSpreadGun -> chooseMovementSpreadGun
ChooseMovementLtAuto -> chooseMovementLtAuto
ChooseMovementLtAuto -> chooseMovementLtAuto
chooseMovementSpreadGun :: Creature -> World -> Action
chooseMovementSpreadGun cr w
| dist cpos p < 30 && safeAngleVV (p -.- cpos) (unitVectorAtAngle (_crDir cr)) > pi
= DoImpulses [UseItem, MoveForward (-3)]
| d < 30 = DoImpulses [UseItem,TurnToward p 0.06]
| d < 60 = DoImpulses [UseItem,TurnToward p 0.06,MoveForward 3]
| d < 100 = DoImpulses [TurnToward p 0.06, MoveForward 3 ]
| d < 200 = DoImpulses [TurnToward p (0.06 + 0.002 *(d-100)), MoveForward 3 ]
| otherwise
= DoImpulses [TurnToward p 0.26, MoveForward 3]
| dist cpos p < 30 && safeAngleVV (p -.- cpos) (unitVectorAtAngle (_crDir cr)) > pi =
DoImpulses [UseItem, MoveForward (-3)]
| d < 30 = DoImpulses [UseItem, TurnToward p 0.06]
| d < 60 = DoImpulses [UseItem, TurnToward p 0.06, MoveForward 3]
| d < 100 = DoImpulses [TurnToward p 0.06, MoveForward 3]
| d < 200 = DoImpulses [TurnToward p (0.06 + 0.002 * (d -100)), MoveForward 3]
| otherwise =
DoImpulses [TurnToward p 0.26, MoveForward 3]
where
d = dist cpos p
cpos = _crPos cr
@@ -97,12 +102,12 @@ chooseMovementSpreadGun cr w
chooseMovementLtAuto :: Creature -> World -> Action
chooseMovementLtAuto cr w
| dist cpos p > 200 = DoImpulses [UseItem,TurnToward p 0.05 , MoveForward 3]
| dist cpos p < 80 = DoImpulses [UseItem,TurnToward p 0.05, MoveForward (-3) ]
| errorAngleVV 22 (p' -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4
= DoImpulses [UseItem,TurnToward p' 0.01, Move (V2 0 3)]
| otherwise
= DoImpulses [UseItem,TurnToward p' 0.05, Move (V2 0 3)]
| dist cpos p > 200 = DoImpulses [UseItem, TurnToward p 0.05, MoveForward 3]
| dist cpos p < 80 = DoImpulses [UseItem, TurnToward p 0.05, MoveForward (-3)]
| errorAngleVV 22 (p' -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4 =
DoImpulses [UseItem, TurnToward p' 0.01, Move (V2 0 3)]
| otherwise =
DoImpulses [UseItem, TurnToward p' 0.05, Move (V2 0 3)]
where
cpos = _crPos cr
tcr = _creatures (_cWorld w) IM.! 0
@@ -112,5 +117,5 @@ chooseMovementLtAuto cr w
fleeFrom :: Creature -> Maybe Creature -> Action
fleeFrom cr mtcr = case mtcr of
Just tcr -> DoImpulses [MoveForward 3, TurnToward ((2 *.* _crPos cr) -.- _crPos tcr) (pi/4)]
Just tcr -> DoImpulses [MoveForward 3, TurnToward ((2 *.* _crPos cr) -.- _crPos tcr) (pi / 4)]
Nothing -> NoAction
src/Dodge/CullBox.hs
+16 -16
View File
@@ -1,28 +1,28 @@
module Dodge.CullBox
( updateBounds
)
where
import Dodge.Data
import Dodge.Base.Window
import Geometry
import Dodge.Update.Camera
module Dodge.CullBox (
updateBounds,
) where
import Data.Maybe
import Control.Lens
import Data.Maybe
import Dodge.Base.Window
import Dodge.Data.Universe
import Dodge.Update.Camera
import Geometry
findBoundDists :: Configuration -> World -> (Float,Float,Float,Float)
findBoundDists :: Configuration -> World -> (Float, Float, Float, Float)
findBoundDists cfig w
| debugOn Bound_box_screen cfig = (hh,-hh,hw,-hw)
| otherwise = fromMaybe (0,0,0,0) $ farWallDistDirection (_cameraCenter (_cWorld w)) w
| debugOn Bound_box_screen cfig = (hh, - hh, hw, - hw)
| otherwise = fromMaybe (0, 0, 0, 0) $ farWallDistDirection (_cameraCenter (_cWorld w)) w
where
hw = halfWidth cfig
hh = halfHeight cfig
updateBounds :: Universe -> Universe
updateBounds uv = uv
& uvWorld . cWorld . boundDist .~ bdists
& uvWorld . cWorld . boundBox .~ map ( (+.+ _cameraCenter (_cWorld w)) . rotateV (_cameraRot (_cWorld w)) ) (rectNSWE n s w' e)
updateBounds uv =
uv
& uvWorld . cWorld . boundDist .~ bdists
& uvWorld . cWorld . boundBox .~ map ((+.+ _cameraCenter (_cWorld w)) . rotateV (_cameraRot (_cWorld w))) (rectNSWE n s w' e)
where
w = _uvWorld uv
cfig = _uvConfig uv
bdists@(n,s,e,w') = findBoundDists cfig w
bdists@(n, s, e, w') = findBoundDists cfig w
src/Dodge/Cuse.hs
+1 -1
View File
@@ -1,7 +1,7 @@
module Dodge.Cuse where
import Dodge.Data
import Control.Lens
import Dodge.Data.World
useC :: Cuse -> Item -> Creature -> World -> World
useC cu = case cu of
src/Dodge/Damage.hs
+6 -4
View File
@@ -1,15 +1,17 @@
module Dodge.Damage where
import Dodge.Data
import qualified Data.Map.Strict as M
import Dodge.Data.CrWlID
import Dodge.Data.World
import Dodge.Wall.Damage
import FoldableHelp
import Geometry.Vector
import LensHelp
import qualified Data.Map.Strict as M
damageCrWlID :: Damage -> CrWlID -> World -> World
damageCrWlID dam crwl = case crwl of
NothingID -> id
CrID cid -> cWorld . creatures . ix cid . crState . csDamage .:~ dam
CrID cid -> cWorld . creatures . ix cid . crState . csDamage .:~ dam
WlID wlid -> cWorld . wallDamages . ix wlid .:~ dam
damageCrWall :: Damage -> Either Creature Wall -> World -> World
@@ -26,5 +28,5 @@ collectDamageTypes = foldr f M.empty
where
f dm = M.insertWith (+) (_dmType dm) (_dmAmount dm)
maxDamageType :: [Damage] -> Maybe (DamageType,Int)
maxDamageType :: [Damage] -> Maybe (DamageType, Int)
maxDamageType = safeMinimumOn (negate . snd) . M.assocs . collectDamageTypes
src/Dodge/DamageCircle.hs
+24 -16
View File
@@ -1,17 +1,19 @@
module Dodge.DamageCircle
( damageCircle
) where
import Dodge.Data
import Dodge.WorldEvent.ThingsHit
import Geometry
import LensHelp
module Dodge.DamageCircle (
damageCircle,
) where
import Data.Foldable
import Dodge.Data.World
import Dodge.WorldEvent.ThingsHit
import Geometry
import qualified IntMapHelp as IM
import LensHelp
damageCircle :: Float -> Point2 -> DamageType -> Int -> World -> World
damageCircle r sp dt da w = w
& cWorld . wallDamages %~ addwalldamages
& cWorld . creatures %~ addcreaturedamages
damageCircle r sp dt da w =
w
& cWorld . wallDamages %~ addwalldamages
& cWorld . creatures %~ addcreaturedamages
where
--addwalldamages wlds = runIdentity $ S.fold_ (damageWlCircle wldam) wlds id wlstodam
addwalldamages wlds = foldl' (damageWlCircle wldam) wlds wlstodam
@@ -21,10 +23,16 @@ damageCircle r sp dt da w = w
crdam p cr = Damage dt da sp p (_crPos cr) NoDamageEffect
crstodam = crsHitRadial sp r w
damageWlCircle :: (Point2 -> Damage)
-> IM.IntMap [Damage] -> (Point2,Wall) -> IM.IntMap [Damage]
damageWlCircle f wldams (p,wl) = IM.insertWith (++) (_wlID wl) [f p] wldams
damageWlCircle ::
(Point2 -> Damage) ->
IM.IntMap [Damage] ->
(Point2, Wall) ->
IM.IntMap [Damage]
damageWlCircle f wldams (p, wl) = IM.insertWith (++) (_wlID wl) [f p] wldams
damageCrCircle :: (Point2 -> Creature -> Damage)
-> IM.IntMap Creature -> (Point2,Creature) -> IM.IntMap Creature
damageCrCircle crdam crs (p,cr) = crs & ix (_crID cr) . crState . csDamage .:~ crdam p cr
damageCrCircle ::
(Point2 -> Creature -> Damage) ->
IM.IntMap Creature ->
(Point2, Creature) ->
IM.IntMap Creature
damageCrCircle crdam crs (p, cr) = crs & ix (_crID cr) . crState . csDamage .:~ crdam p cr
src/Dodge/Data.hs
+10 -265
View File
@@ -1,27 +1,22 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- |
Contains base datatypes that cannot be seperated into
different modules because they are interdependent;
circular imports are probably not a good idea.
WARNING: orphan instances concerning Aeson classes and SDL datatypes have been introduced.
The warnings have been disabled.
-}
module Dodge.Data (
module Dodge.Data,
module Dodge.Data.World,
module Dodge.Data.WorldEffect,
module Dodge.Data.ArcStep,
module Dodge.Data.Config,
module Dodge.Data.Zoning,
module Dodge.Data.Distortion,
module Dodge.Data.Material,
module Dodge.Data.SoundOrigin,
module Dodge.Data.GenWorld,
module Dodge.Data.Universe,
module Dodge.Data.Hammer,
module Dodge.Data.RightButtonOptions,
module Dodge.Data.Config,
module MaybeHelp,
module Dodge.Data.RoomCluster,
module Dodge.Data.Room,
@@ -32,272 +27,22 @@ module Dodge.Data (
module Dodge.Data.MountedObject,
) where
import Color
import Control.Lens
import Control.Monad.State
import qualified Data.Map.Strict as M
import Data.Preload
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Tile
import Dodge.Config.KeyConfig
import Dodge.Data.Config
import Dodge.Data.WorldEffect
import Dodge.Data.ActionPlan
import Dodge.Data.ArcStep
import Dodge.Data.CWorld
import Dodge.Data.Config
import Dodge.Data.CrWlID
import Dodge.Data.CreatureEffect
import Dodge.Data.Distortion
import Dodge.Data.GenWorld
import Dodge.Data.Hammer
import Dodge.Data.Material
import Dodge.Data.MountedObject
import Dodge.Data.ObjectType
import Dodge.Data.RightButtonOptions
import Dodge.Data.Room
import Dodge.Data.RoomCluster
import Dodge.Data.SoundOrigin
import Dodge.Data.Universe
import Dodge.Data.World
import Dodge.Data.Zoning
import Geometry.Data
import qualified IntMapHelp as IM
import MaybeHelp
import Picture.Data
import SDL (MouseButton, Scancode)
import Sound.Data
import Streaming
import System.Random
type CRUpdate' = Creature -> World -> (World -> World, Creature)
data Universe = Universe
{ _uvWorld :: World
, _preloadData :: PreloadData
, _menuLayers :: [ScreenLayer]
, _savedWorlds :: M.Map SaveSlot World
, _keyConfig :: KeyConfigSDL
, _uvIOEffects :: Universe -> IO Universe
, _uvConfig :: Configuration
, _uvTestString :: Universe -> [String]
}
data GenWorld = GenWorld
{ _gwWorld :: World
, _genPlacements :: IM.IntMap [(Placement, Int)]
, _genRooms :: IM.IntMap Room
}
data World = World
{ _cWorld :: CWorld
, _randGen :: StdGen
, _toPlaySounds :: M.Map SoundOrigin Sound
, _playingSounds :: M.Map SoundOrigin Sound
, _mousePos :: Point2
, _keys :: S.Set Scancode
, _mouseButtons :: M.Map MouseButton Bool
, _hammers :: M.Map WorldHammer HammerPosition
, _testFloat :: Float
, _lLine :: (Point2, Point2)
, _rLine :: (Point2, Point2)
, _lSelect :: Point2
, _rSelect :: Point2
, _backspaceTimer :: Int
, _timeFlow :: TimeFlowStatus
, _rbOptions :: RightButtonOptions
}
data TimeFlowStatus
= RewindingNow
| RewindingLastFrame
| NormalTimeFlow
deriving (Eq, Ord, Show, Read)
data WorldHammer
= SubInvHam
| DoubleMouseHam
deriving (Eq, Ord, Show, Read, Enum, Bounded)
data SaveSlot
= QuicksaveSlot
| LevelStartSlot
| SaveSlotNum Int
deriving (Eq, Ord, Show, Read)
data OptionScreenFlag = NormalOptions | GameOverOptions
deriving (Eq, Ord, Show, Read)
data ScreenLayer
= OptionScreen
{ _scTitle :: Universe -> String
, _scOptions :: [MenuOption]
, _scDefaultEff :: Universe -> IO (Maybe Universe)
, _scOptionFlag :: OptionScreenFlag
, _scOptionsOffset :: Int
}
| ColumnsScreen
{ _scTitle :: Universe -> String
, _scColumns :: [(String, String)]
}
| InputScreen
{ _scInput :: T.Text
, _scFooter :: String
}
| WaitScreen
{ _scWaitMessage :: Universe -> String
, _scWaitTime :: Int
}
| DisplayScreen
{ _scDisplay :: Universe -> Picture
}
data MenuOption
= Toggle
{ _moEff :: Universe -> IO (Maybe Universe)
, _moString :: Universe -> Either String (String, String)
, _moKey :: Scancode
}
| Toggle2
{ _moKey1 :: Scancode
, _moEff1 :: Universe -> IO (Maybe Universe)
, _moKey2 :: Scancode
, _moEff2 :: Universe -> IO (Maybe Universe)
, _moString :: Universe -> Either String (String, String)
}
| InvisibleToggle
{ _moKey :: Scancode
, _moEff :: Universe -> IO (Maybe Universe)
}
data IntID a = IntID Int a
type HitEffect' =
Flame ->
Stream (Of (Point2, Either Creature Wall)) Identity () ->
World ->
(World, Maybe Flame)
---- ROOM DATATYPES
data PSType
= PutCrit {_unPutCrit :: Creature}
| PutMachine {_putMachinePoly :: [Point2], _putMachineMachine :: Machine, _putMachineWall :: Wall}
| PutLS LightSource
| PutButton {_putButton :: Button}
| PutProp Prop
| PutTerminal {_unputTerminal :: Terminal}
| PutFlIt {_putItem :: Item}
| PutPPlate PressPlate
| PutBlock {_putBlock :: Block, _putWall :: Wall, _putPoly :: [Point2]}
| PutCoord Point2
| PutMod Modification
| PutTrigger Bool
| PutLineBlock
{ _putWall :: Wall
, _putWidth :: Float
, _putStartPoint :: Point2
, _putEndPoint :: Point2
}
| PutWall {_pwPoly :: [Point2], _pwWall :: Wall}
| PutSlideDr Door Wall EdgeObstacle Float Point2 Point2
| PutDoor Color EdgeObstacle WdBl [(Point2, Point2)]
| RandPS (State StdGen PSType)
| PutForeground ForegroundShape
| PutDecoration Picture
| PutWorldUpdate (PlacementSpot -> World -> World)
| PutNothing
| PutUsingGenParams (World -> (World, PSType))
| PutID {_putID :: Int}
-- maybe there is a monadic implementation of this?
-- add room effect for any placement spot?
data PlacementSpot
= PS {_psPos :: Point2, _psRot :: Float}
| PSNoShiftCont {_psPos :: Point2, _psRot :: Float}
| PSPos
{ _psSelect :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)
, _psRoomEff :: RoomPos -> Room -> Room
, _psFallback :: Maybe Placement
}
| PSRoomRand
{ _psRoomRandPointNum :: Int
, _psRandShift :: (Point2, Float) -> PlacementSpot
}
-- TODO attempt to unify/simplify this union type
data Placement
= Placement
{ _plOrder :: Int
, _plSpot :: PlacementSpot
, _plType :: PSType
, _plMID :: Maybe Int
, _plIDCont :: World -> Placement -> Maybe Placement
}
| PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position
| RandomPlacement {_unRandomPlacement :: State StdGen Placement}
| PickOnePlacement Int Placement
{- The '_rmPolys' lists which polygons should be cut out to form the indestructible walls of the room.
Link pairs contain a position and rotation to attach to another room;
0 is for links going to another room to the north, pi/2 for links going to a room to the west, etc.
TODO : Explain path, does it need both directions?
Placement spots allow things to be put in the room during level generation.
Room bounds between a new room and previously placed rooms are checked during level generation,
assigning no bounds will allow rooms to overlap. -}
data Room = Room
{ _rmPolys :: [[Point2]]
, _rmLinks :: [RoomLink]
, -- the Int is the number of previous outlinks that have been assigned
_rmLinkEff ::
RoomLink -> -- child link
Room -> -- child room
Int -> -- child number
RoomLink -> -- parent link
Room -> -- parent room
Room
, _rmPos :: [RoomPos]
, _rmPath :: S.Set (Point2, Point2)
, _rmPmnts :: [Placement]
, _rmInPmnt :: [InPlacement]
, _rmOutPmnt :: [OutPlacement]
, _rmBound :: [[Point2]]
, _rmFloor :: Floor
, _rmName :: String
, _rmShift :: (Point2, Float)
, _rmViewpoints :: [Point2]
, _rmRandPSs :: [State StdGen (Point2, Float)]
, _rmStartWires :: IM.IntMap RoomWire
, _rmEndWires :: IM.IntMap RoomWire
, _rmConnectsTo :: S.Set RoomLinkType -> Bool
, _rmMID :: Maybe Int
, _rmMParent :: Maybe Int
, _rmChildren :: [Int]
, _rmType :: RoomType
, _rmClusterStatus :: ClusterStatus
}
data OutPlacement = OutPlacement
{ _opPlacement :: Placement
, _opPlacementID :: Int
}
data InPlacement = InPlacement
{ _ipPlacement :: [Placement] -> Placement
, _ipPlacementID :: Int
}
makeLenses ''World
makeLenses ''Universe
makeLenses ''ScreenLayer
makeLenses ''GenWorld
----- ROOM LENSES
makeLenses ''Room
makeLenses ''RoomType
makeLenses ''PSType
makeLenses ''PlacementSpot
makeLenses ''Placement
_itUseAimStance :: Item -> AimStance
_itUseAimStance = _aimStance . _useAim . _itUse
crSel :: Creature -> Int
crSel = _iselPos . _crInvSel
src/Dodge/Data.hs.orig
+1 -1
View File
@@ -1,5 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
--{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data
( module Dodge.Data
src/Dodge/Data/ArcStep.hs
+5 -14
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
@@ -6,8 +5,8 @@ module Dodge.Data.ArcStep where
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Dodge.Data.CrWlID
import GHC.Generics
import Geometry.Data
data ArcStep = ArcStep
@@ -15,21 +14,13 @@ data ArcStep = ArcStep
, _asDir :: Float
, _asObject :: CrWlID --Maybe (Either Creature Wall)
}
deriving (Eq, Ord, Show, Read, Generic)
instance ToJSON ArcStep where
toEncoding = genericToEncoding defaultOptions
instance FromJSON ArcStep
deriving (Eq, Ord, Show, Read)
data NextArcStep
= EndArc
| DefaultArcStep
deriving (Eq, Ord, Show, Read, Generic)
instance ToJSON NextArcStep where
toEncoding = genericToEncoding defaultOptions
instance FromJSON NextArcStep
deriving (Eq, Ord, Show, Read)
makeLenses ''ArcStep
deriveJSON defaultOptions ''ArcStep
deriveJSON defaultOptions ''NextArcStep
src/Dodge/Data/Beam.hs
+30 -30
View File
@@ -1,56 +1,56 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Beam where
import GHC.Generics
import Data.Aeson
import Geometry.Data
import Color
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Geometry.Data
{- | Linear beams. Last only one frame.
- Can interact with one another in a limited manner
- can probably be moved to a separate file
-}
-}
data Beam = Beam
{ _bmDraw :: BeamDraw -- Beam -> Picture
, _bmPos :: Point2
, _bmDir :: Float
{ _bmDraw :: BeamDraw -- Beam -> Picture
, _bmPos :: Point2
, _bmDir :: Float
, _bmDamage :: Int
, _bmColor :: Color
, _bmColor :: Color
, _bmPoints :: [Point2]
, _bmFirstPoints :: [Point2]
, _bmRange :: Float
, _bmRange :: Float
, _bmPhaseV :: Float
, _bmOrigin :: Maybe Int
, _bmType :: BeamType
, _bmType :: BeamType
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Beam where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Beam
data BeamDraw = BasicBeamDraw
deriving (Eq, Ord, Show, Read)
data BeamDraw
= BasicBeamDraw
| BeamDrawColor Color
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON BeamDraw where
toEncoding = genericToEncoding defaultOptions
instance FromJSON BeamDraw
data BeamCombineType = FlameBeamCombine
deriving (Eq, Ord, Show, Read)
data BeamCombineType
= FlameBeamCombine
| LasBeamCombine
| TeslaBeamCombine
| SplitBeamCombine
| NoBeamCombine
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON BeamCombineType where
toEncoding = genericToEncoding defaultOptions
instance FromJSON BeamCombineType
deriving (Eq, Ord, Show, Read)
data BeamType
= BeamCombine
{ _beamCombine :: BeamCombineType -- (Point2 , (Point2,Point2,Beam) , (Point2,Point2,Beam)) -> World -> World
}
| BeamSimple
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON BeamType where
toEncoding = genericToEncoding defaultOptions
instance FromJSON BeamType
deriving (Eq, Ord, Show, Read)
makeLenses ''BeamType
makeLenses ''Beam
deriveJSON defaultOptions ''BeamType
deriveJSON defaultOptions ''Beam
deriveJSON defaultOptions ''BeamDraw
deriveJSON defaultOptions ''BeamCombineType
src/Dodge/Data/Block.hs
+38 -33
View File
@@ -1,45 +1,50 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data.Block where
import GHC.Generics
import Data.Aeson
import Shape.Data
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Block (
module Dodge.Data.Block,
module Dodge.Data.Material,
module Dodge.Data.PathGraph,
) where
import Color
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import qualified Data.IntSet as IS
import Dodge.Data.Material
import Dodge.Data.PathGraph
import Geometry
import Control.Lens
import qualified Data.IntSet as IS
import Shape.Data
data Block = Block
{ _blID :: Int
, _blWallIDs :: IS.IntSet
, _blHP :: Int
, _blShadows :: [Int] -- a list of blocks/walls? that are not shown when this block exists
, _blFootprint :: [Point2]
, _blPos :: Point2
, _blDir :: Float
, _blHeight :: Float
, _blMaterial :: Material
, _blDraw :: BlockDraw --Block -> SPic
, _blObstructs :: [(Int,Int,PathEdge)]
{ _blID :: Int
, _blWallIDs :: IS.IntSet
, _blHP :: Int
, _blShadows :: [Int] -- a list of blocks/walls? that are not shown when this block exists
, _blFootprint :: [Point2]
, _blPos :: Point2
, _blDir :: Float
, _blHeight :: Float
, _blMaterial :: Material
, _blDraw :: BlockDraw --Block -> SPic
, _blObstructs :: [(Int, Int, PathEdge)]
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Block where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Block
data BlockDraw = BlockDrawMempty
deriving (Eq, Ord, Show, Read)
data BlockDraw
= BlockDrawMempty
| BlockDrawBlSh BlSh
| BlockDraws [BlockDraw]
| BlockDrawColHeightPoss Color Float [Point2]
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON BlockDraw where
toEncoding = genericToEncoding defaultOptions
instance FromJSON BlockDraw
data BlSh = BlShMempty
deriving (Eq, Ord, Show, Read)
data BlSh
= BlShMempty
| BlShConst Shape
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON BlSh where
toEncoding = genericToEncoding defaultOptions
instance FromJSON BlSh
deriving (Eq, Ord, Show, Read)
makeLenses ''Block
deriveJSON defaultOptions ''Block
deriveJSON defaultOptions ''BlockDraw
deriveJSON defaultOptions ''BlSh
src/Dodge/Data/Bounds.hs
+12 -13
View File
@@ -1,23 +1,22 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data.Bounds
where
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Bounds where
import Control.Lens
import GHC.Generics
import Data.Aeson
import Data.Aeson.TH
data Bounds = Bounds
{ _bdMinX :: Float
, _bdMaxX :: Float
, _bdMinY :: Float
, _bdMaxY :: Float
{ _bdMinX :: Float
, _bdMaxX :: Float
, _bdMinY :: Float
, _bdMaxY :: Float
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Bounds where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Bounds
deriving (Eq, Ord, Show, Read)
defaultBounds :: Bounds
defaultBounds = Bounds 0 0 0 0
makeLenses ''Bounds
deriveJSON defaultOptions ''Bounds
src/Dodge/Data/Bullet.hs
+4 -2
View File
@@ -1,8 +1,10 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Bullet where
module Dodge.Data.Bullet
( module Dodge.Data.Bullet
, module Dodge.Data.Damage
)where
import Control.Lens
import Data.Aeson
src/Dodge/Data/Button.hs
+50 -50
View File
@@ -1,67 +1,67 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Button where
import GHC.Generics
import Data.Aeson
import Dodge.Data.WorldEffect
import Color
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Dodge.Data.WorldEffect
import Geometry.Data
import Sound.Data
import Color
data ButtonDraw = DefaultDrawButton Color
data ButtonDraw
= DefaultDrawButton Color
| DefaultDrawSwitch Color Color
| DrawNoButton
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON ButtonDraw where
toEncoding = genericToEncoding defaultOptions
instance FromJSON ButtonDraw
data ButtonEvent = ButtonDoNothing
deriving (Eq, Ord, Show, Read)
data ButtonEvent
= ButtonDoNothing
| ButtonPress
{_bpState :: ButtonState
,_bpEvent :: ButtonEvent
,_bpSound :: SoundID
,_bpEff :: WdWd
{ _bpState :: ButtonState
, _bpEvent :: ButtonEvent
, _bpSound :: SoundID
, _bpEff :: WdWd
}
-- | ButtonSwitch
-- {_bonState :: ButtonState
-- ,_bonEvent :: ButtonEvent
-- ,_bonSound :: SoundID
-- ,_bonEff :: WorldEffect
-- ,_boffState :: ButtonState
-- ,_boffEvent :: ButtonEvent
-- ,_boffSound :: SoundID
-- ,_boffEff :: WorldEffect
-- }
| ButtonSimpleSwith
{_bonEff :: WdWd
,_boffEff :: WdWd
| -- | ButtonSwitch
-- {_bonState :: ButtonState
-- ,_bonEvent :: ButtonEvent
-- ,_bonSound :: SoundID
-- ,_bonEff :: WorldEffect
-- ,_boffState :: ButtonState
-- ,_boffEvent :: ButtonEvent
-- ,_boffSound :: SoundID
-- ,_boffEff :: WorldEffect
-- }
ButtonSimpleSwith
{ _bonEff :: WdWd
, _boffEff :: WdWd
}
| ButtonAccessTerminal
deriving (Eq,Show,Read,Generic)
instance ToJSON ButtonEvent where
toEncoding = genericToEncoding defaultOptions
instance FromJSON ButtonEvent
deriving (Eq, Show, Read)
data Button = Button
{ _btPict :: ButtonDraw --Button -> SPic
, _btPos :: Point2
, _btRot :: Float
, _btEvent :: ButtonEvent --Button -> World -> World
, _btID :: Int
, _btText :: String
, _btState :: ButtonState
{ _btPict :: ButtonDraw --Button -> SPic
, _btPos :: Point2
, _btRot :: Float
, _btEvent :: ButtonEvent --Button -> World -> World
, _btID :: Int
, _btText :: String
, _btState :: ButtonState
, _btTermMID :: Maybe Int
, _btName :: String
, _btColor :: Color
, _btName :: String
, _btColor :: Color
}
deriving (Eq,Show,Read,Generic)
instance ToJSON Button where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Button
deriving (Eq, Show, Read)
data ButtonState = BtOn | BtOff | BtNoLabel
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON ButtonState where
toEncoding = genericToEncoding defaultOptions
instance FromJSON ButtonState
deriving (Eq, Ord, Show, Read)
makeLenses ''Button
makeLenses ''ButtonEvent
deriveJSON defaultOptions ''ButtonDraw
deriveJSON defaultOptions ''ButtonEvent
deriveJSON defaultOptions ''Button
deriveJSON defaultOptions ''ButtonState
src/Dodge/Data/CamouflageStatus.hs
+9 -6
View File
@@ -1,11 +1,14 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.CamouflageStatus where
import GHC.Generics
import Data.Aeson
import Data.Aeson.TH
data CamouflageStatus
= FullyVisible
| Invisible
deriving (Eq,Ord,Enum,Read,Show,Bounded,Generic)
instance ToJSON CamouflageStatus where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CamouflageStatus
deriving (Eq, Ord, Enum, Read, Show, Bounded)
deriveJSON defaultOptions ''CamouflageStatus
src/Dodge/Data/Cloud.hs
+18 -18
View File
@@ -1,18 +1,19 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Cloud where
import GHC.Generics
import Data.Aeson
import Geometry
import Color
import Control.Lens
data CloudDraw = CloudColor Float Float Color -- radius-multiply fade-time color
import Data.Aeson
import Data.Aeson.TH
import Geometry
data CloudDraw
= CloudColor Float Float Color -- radius-multiply fade-time color
| DrawGasCloud Color
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON CloudDraw where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CloudDraw
deriving (Eq, Ord, Show, Read)
data Cloud = Cloud
{ _clPos :: Point3
, _clVel :: Point3
@@ -22,15 +23,14 @@ data Cloud = Cloud
, _clTimer :: Int
, _clType :: CloudType
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Cloud where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Cloud
deriving (Eq, Ord, Show, Read)
data CloudType
= SmokeCloud
| GasCloud
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON CloudType where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CloudType
deriving (Eq, Ord, Show, Read)
makeLenses ''Cloud
deriveJSON defaultOptions ''CloudDraw
deriveJSON defaultOptions ''Cloud
deriveJSON defaultOptions ''CloudType
src/Dodge/Data/Config.hs
+11 -39
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
@@ -6,8 +5,8 @@ module Dodge.Data.Config where
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import qualified Data.Set as S
import GHC.Generics
{-# ANN module "HLint: ignore Use camelCase" #-}
@@ -27,7 +26,7 @@ data Configuration = Configuration
, _debug_view_clip_bounds :: RoomClipping
, _debug_booleans :: S.Set DebugBool -- consider using Data.BitSet
}
deriving (Generic, Show)
deriving (Show)
data DebugBool
= Show_ms_frame
@@ -52,23 +51,13 @@ data DebugBool
| Inspect_wall
| Show_nodes_near_select
| Show_path_between
deriving (Generic, Eq, Ord, Bounded, Enum, Show)
deriving (Eq, Ord, Bounded, Enum, Show)
data ResFactor = FullRes | HalfRes | QuarterRes
deriving (Generic, Show, Eq, Ord, Enum, Bounded)
instance ToJSON ResFactor where
toEncoding = genericToEncoding defaultOptions
instance FromJSON ResFactor
deriving (Show, Eq, Ord, Enum, Bounded)
data RoomClipping = NoRoomClipBoundaries | AllRoomClipBoundaries | IntersectingRoomClipBoundaries
deriving (Generic, Show, Eq, Ord, Enum, Bounded)
instance ToJSON RoomClipping where
toEncoding = genericToEncoding defaultOptions
instance FromJSON RoomClipping
deriving (Show, Eq, Ord, Enum, Bounded)
resFactorNum :: ResFactor -> Int
resFactorNum rf = case rf of
@@ -76,18 +65,6 @@ resFactorNum rf = case rf of
HalfRes -> 2
QuarterRes -> 4
makeLenses ''Configuration
instance ToJSON DebugBool where
toEncoding = genericToEncoding defaultOptions
instance FromJSON DebugBool
instance ToJSON Configuration where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Configuration
defaultConfig :: Configuration
defaultConfig =
Configuration
@@ -105,18 +82,13 @@ defaultConfig =
, _gameplay_rotate_to_wall = True
, _debug_booleans = S.singleton Show_ms_frame
, _debug_view_clip_bounds = NoRoomClipBoundaries
-- , _debug_show_sound = False
-- , _debug_seconds_frame = True
-- , _debug_noclip = False
-- , _debug_mouse_position = False
-- , _debug_cr_status = False
-- , _debug_cr_awareness = False
-- , _debug_view_boundaries = False
-- , _debug_pathing = False
-- , _debug_walls = False
-- , _debug_remove_LOS = False
-- , _debug_cull_more_lights = False
}
debugOn :: DebugBool -> Configuration -> Bool
debugOn db = S.member db . _debug_booleans
makeLenses ''Configuration
deriveJSON defaultOptions ''ResFactor
deriveJSON defaultOptions ''RoomClipping
deriveJSON defaultOptions ''DebugBool
deriveJSON defaultOptions ''Configuration
src/Dodge/Data/Corpse.hs
+14 -15
View File
@@ -1,27 +1,26 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Corpse where
import GHC.Generics
import Data.Aeson
import ShapePicture.Data
import Geometry.Data
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Geometry.Data
import ShapePicture.Data
data CorpseResurrection = NoResurrection
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON CorpseResurrection where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CorpseResurrection
deriving (Eq, Ord, Show, Read)
data Corpse = Corpse
{ _cpID :: Int
{ _cpID :: Int
, _cpPos :: Point2
, _cpDir :: Float
, _cpSPic :: SPic
, _cpRes :: CorpseResurrection
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Corpse where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Corpse
deriving (Eq, Ord, Show, Read)
makeLenses ''Corpse
deriveJSON defaultOptions ''CorpseResurrection
deriveJSON defaultOptions ''Corpse
src/Dodge/Data/CrGroupParams.hs
+19 -20
View File
@@ -1,26 +1,25 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data.CrGroupParams
where
import GHC.Generics
import Data.Aeson
import Geometry.Data
import qualified Data.IntSet as IS
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.CrGroupParams where
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import qualified Data.IntSet as IS
import Geometry.Data
data CrGroupParams = CrGroupParams
{ _crGroupParamID :: Int
, _crGroupIDs :: IS.IntSet
, _crGroupCenter :: Point2
, _crGroupUpdate :: CrGroupUpdate --World -> CrGroupParams -> Maybe CrGroupParams
{ _crGroupParamID :: Int
, _crGroupIDs :: IS.IntSet
, _crGroupCenter :: Point2
, _crGroupUpdate :: CrGroupUpdate --World -> CrGroupParams -> Maybe CrGroupParams
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON CrGroupParams where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CrGroupParams
deriving (Eq, Ord, Show, Read)
data CrGroupUpdate = DefaultCrGroupUpdate
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON CrGroupUpdate where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CrGroupUpdate
deriving (Eq, Ord, Show, Read)
makeLenses ''CrGroupParams
deriveJSON defaultOptions ''CrGroupParams
deriveJSON defaultOptions ''CrGroupUpdate
src/Dodge/Data/Creature.hs
+13 -20
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
@@ -9,11 +8,15 @@ module Dodge.Data.Creature (
module Dodge.Data.Creature.Perception,
module Dodge.Data.Creature.Memory,
module Dodge.Data.Creature.Stance,
module Dodge.Data.ActionPlan
module Dodge.Data.ActionPlan,
module Dodge.Data.Item,
module Dodge.Data.Material,
module Dodge.Data.Hammer,
) where
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import qualified Data.Map.Strict as M
import Dodge.Data.ActionPlan
import Dodge.Data.Creature.Memory
@@ -24,7 +27,6 @@ import Dodge.Data.Creature.State
import Dodge.Data.Hammer
import Dodge.Data.Item
import Dodge.Data.Material
import GHC.Generics
import Geometry.Data
import qualified IntMapHelp as IM
@@ -68,32 +70,23 @@ data Creature = Creature
, _crStatistics :: CreatureStatistics
, _crCamouflage :: CamouflageStatus
}
deriving (Eq, Show, Read, Generic)
instance ToJSON Creature where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Creature
deriving (Eq, Show, Read)
data CreatureCorpse = MakeDefaultCorpse
deriving (Eq, Ord, Show, Read, Generic)
instance ToJSON CreatureCorpse where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CreatureCorpse
deriving (Eq, Ord, Show, Read)
data Intention = Intention
{ _targetCr :: Maybe Creature
, _mvToPoint :: Maybe Point2
, _viewPoint :: Maybe Point2
}
deriving (Eq, Show, Read, Generic)
deriving (Eq, Show, Read)
instance ToJSON Intention where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Intention
crSel :: Creature -> Int
crSel = _iselPos . _crInvSel
makeLenses ''Creature
makeLenses ''Intention
deriveJSON defaultOptions ''Creature
deriveJSON defaultOptions ''CreatureCorpse
deriveJSON defaultOptions ''Intention
src/Dodge/Data/Creature/Memory.hs
+12 -12
View File
@@ -1,18 +1,18 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data.Creature.Memory
where
import GHC.Generics
import Data.Aeson
import Geometry.Data
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Creature.Memory where
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Geometry.Data
data Memory = Memory
{ _soundsToInvestigate :: [Point2]
, _nodesSearched :: [Int]
, _nodesSearched :: [Int]
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Memory where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Memory
deriving (Eq, Ord, Show, Read)
makeLenses ''Memory
deriveJSON defaultOptions ''Memory
src/Dodge/Data/Creature/Misc.hs
+62 -55
View File
@@ -1,80 +1,87 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data.Creature.Misc
( module Dodge.Data.Creature.Misc
, module Dodge.Data.CamouflageStatus
) where
import GHC.Generics
import Data.Aeson
import Dodge.Data.FloatFunction
import Dodge.Data.CamouflageStatus
import Sound.Data
import Geometry.Data
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Creature.Misc (
module Dodge.Data.Creature.Misc,
module Dodge.Data.CamouflageStatus,
) where
import Color
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Dodge.Data.CamouflageStatus
import Dodge.Data.FloatFunction
import Geometry.Data
import Sound.Data
data CreatureStatistics = CreatureStatistics
{ _strength :: Int
, _dexterity :: Int
, _intelligence :: Int
{ _strength :: Int
, _dexterity :: Int
, _intelligence :: Int
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON CreatureStatistics where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CreatureStatistics
deriving (Eq, Ord, Show, Read)
data Vocalization
= Mute
| Vocalization
{_vcSound :: SoundID
,_vcWarnings :: [SoundID]
,_vcMaxCoolDown :: Int
,_vcCoolDown :: Int
{ _vcSound :: SoundID
, _vcWarnings :: [SoundID]
, _vcMaxCoolDown :: Int
, _vcCoolDown :: Int
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Vocalization where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Vocalization
deriving (Eq, Ord, Show, Read)
data CrMvType
= NoMvType
| MvWalking { _mvSpeed :: Float }
| MvWalking {_mvSpeed :: Float}
| CrMvType
{ _mvSpeed :: Float
, _mvTurnRad :: FloatFloat
, _mvTurnJit :: Float
, _mvAimSpeed :: FloatFloat
{ _mvSpeed :: Float
, _mvTurnRad :: FloatFloat
, _mvTurnJit :: Float
, _mvAimSpeed :: FloatFloat
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON CrMvType where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CrMvType
data HumanoidAI = YourAI | ChaseAI | InanimateAI | SpreadGunAI | PistolAI
| LtAutoAI | LauncherAI | SwarmAI | AutoAI | FlockArmourChaseAI | MiniGunAI
| LongAI | MultGunAI
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON HumanoidAI where
toEncoding = genericToEncoding defaultOptions
instance FromJSON HumanoidAI
deriving (Eq, Ord, Show, Read)
data HumanoidAI
= YourAI
| ChaseAI
| InanimateAI
| SpreadGunAI
| PistolAI
| LtAutoAI
| LauncherAI
| SwarmAI
| AutoAI
| FlockArmourChaseAI
| MiniGunAI
| LongAI
| MultGunAI
deriving (Eq, Ord, Show, Read)
data CreatureType
= Humanoid
{ _skinHead :: Color
, _skinUpper :: Color
, _skinLower :: Color
, _humanoidAI :: HumanoidAI
{ _skinHead :: Color
, _skinUpper :: Color
, _skinLower :: Color
, _humanoidAI :: HumanoidAI
}
| Barreloid {_barrelType :: BarrelType}
| Lampoid {_lampHeight :: Float, _lampColor :: Point3, _lampLSID :: Maybe Int}
| Turretoid
| NonDrawnCreature
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON CreatureType where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CreatureType
deriving (Eq, Ord, Show, Read)
data BarrelType = PlainBarrel | ExplosiveBarrel
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON BarrelType where
toEncoding = genericToEncoding defaultOptions
instance FromJSON BarrelType
deriving (Eq, Ord, Show, Read)
makeLenses ''CreatureStatistics
makeLenses ''Vocalization
makeLenses ''CrMvType
makeLenses ''CreatureType
deriveJSON defaultOptions ''CreatureStatistics
deriveJSON defaultOptions ''Vocalization
deriveJSON defaultOptions ''CrMvType
deriveJSON defaultOptions ''HumanoidAI
deriveJSON defaultOptions ''CreatureType
deriveJSON defaultOptions ''BarrelType
src/Dodge/Data/Creature/Perception.hs
+50 -55
View File
@@ -1,82 +1,77 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data.Creature.Perception
( Perception (..)
, Vigilance (..)
, Attention (..)
, Awareness (..)
, Vision (..)
, Audition (..)
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Creature.Perception (
Perception (..),
Vigilance (..),
Attention (..),
Awareness (..),
Vision (..),
Audition (..),
-- lenses
, getAttentiveTo
, getFixated
, cpAttention
, cpVigilance
, cpAwareness
, cpVision
, cpAudition
, viFOV
, viDist
, auDist
)
where
import GHC.Generics
import Data.Aeson
getAttentiveTo,
getFixated,
cpAttention,
cpVigilance,
cpAwareness,
cpVision,
cpAudition,
viFOV,
viDist,
auDist,
) where
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Dodge.Data.FloatFunction
import qualified IntMapHelp as IM
data Perception = Perception
{ _cpVigilance :: Vigilance
, _cpAttention :: Attention
, _cpAwareness :: IM.IntMap Awareness
, _cpVision :: Vision
, _cpAudition :: Audition
{ _cpVigilance :: Vigilance
, _cpAttention :: Attention
, _cpAwareness :: IM.IntMap Awareness
, _cpVision :: Vision
, _cpAudition :: Audition
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Perception where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Perception
deriving (Eq, Ord, Show, Read)
data Vision = Eyes
{ _viFOV :: FloatFloat
{ _viFOV :: FloatFloat
, _viDist :: FloatFloat
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Vision where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Vision
deriving (Eq, Ord, Show, Read)
newtype Audition = Ears
{ _auDist :: FloatFloat
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Audition where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Audition
deriving (Eq, Ord, Show, Read)
data Vigilance
= Comatose
| Asleep
| Lethargic
| Vigilant
| Overstrung
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Vigilance where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Vigilance
deriving (Eq, Ord, Show, Read)
data Attention
= AttentiveTo {_getAttentiveTo :: IM.IntMap Awareness }
| Fixated {_getFixated :: Int }
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Attention where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Attention
= AttentiveTo {_getAttentiveTo :: IM.IntMap Awareness}
| Fixated {_getFixated :: Int}
deriving (Eq, Ord, Show, Read)
data Awareness
= Suspicious Float
| Cognizant Float
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Awareness where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Awareness
deriving (Eq, Ord, Show, Read)
makeLenses ''Perception
makeLenses ''Vision
makeLenses ''Audition
makeLenses ''Attention
deriveJSON defaultOptions ''Perception
deriveJSON defaultOptions ''Vision
deriveJSON defaultOptions ''Audition
deriveJSON defaultOptions ''Vigilance
deriveJSON defaultOptions ''Attention
deriveJSON defaultOptions ''Awareness
src/Dodge/Data/Creature/Stance.hs
+24 -27
View File
@@ -1,22 +1,20 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data.Creature.Stance
where
import GHC.Generics
import Data.Aeson
import Geometry.Data
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Creature.Stance where
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Geometry.Data
data Stance = Stance
{_carriage :: Carriage
,_posture :: Posture
,_strideLength :: Int
{ _carriage :: Carriage
, _posture :: Posture
, _strideLength :: Int
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Stance where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Stance
deriving (Eq, Ord, Show, Read)
data Carriage
= Walking
{ _strideAmount :: Int
@@ -26,25 +24,24 @@ data Carriage
| Floating
| Flying
| Boosting Point2
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Carriage where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Carriage
deriving (Eq, Ord, Show, Read)
data FootForward
= LeftForward
| RightForward
| WasLeftForward
| WasRightForward
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON FootForward where
toEncoding = genericToEncoding defaultOptions
instance FromJSON FootForward
data Posture = Aiming
deriving (Eq, Ord, Show, Read)
data Posture
= Aiming
| AtEase
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Posture where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Posture
deriving (Eq, Ord, Show, Read)
makeLenses ''Stance
makeLenses ''Carriage
makeLenses ''Posture
deriveJSON defaultOptions ''Stance
deriveJSON defaultOptions ''Carriage
deriveJSON defaultOptions ''FootForward
deriveJSON defaultOptions ''Posture
src/Dodge/Data/Creature/State.hs
+11 -32
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
@@ -7,9 +6,9 @@ module Dodge.Data.Creature.State where
import Color
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import qualified Data.IntSet as IS
import Dodge.Data.Damage
import GHC.Generics
import Geometry.Data
data CreatureState = CrSt
@@ -17,33 +16,18 @@ data CreatureState = CrSt
, _csSpState :: CrSpState
, _csDropsOnDeath :: CreatureDropType
}
deriving (Eq, Ord, Show, Read, Generic)
instance ToJSON CreatureState where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CreatureState
deriving (Eq, Ord, Show, Read)
data CreatureDropType
= DropAll
| DropAmount Int
| DropSpecific [Int]
deriving (Eq, Ord, Show, Read, Generic)
instance ToJSON CreatureDropType where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CreatureDropType
deriving (Eq, Ord, Show, Read)
data CrSpState
= Barrel {_piercedPoints :: [Point2]}
| GenCr
deriving (Eq, Ord, Show, Read, Generic)
instance ToJSON CrSpState where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CrSpState
deriving (Eq, Ord, Show, Read)
data Faction
= GenericFaction Int
@@ -54,12 +38,7 @@ data Faction
| NoFaction
| ColorFaction Color
| PlayerFaction
deriving (Eq, Ord, Show, Read, Generic)
instance ToJSON Faction where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Faction
deriving (Eq, Ord, Show, Read)
data CrGroup
= LoneWolf
@@ -69,13 +48,13 @@ data CrGroup
}
| CrGroupID {_crGroupID :: Int}
| ShieldGroup
deriving (Eq, Ord, Show, Read, Generic)
instance ToJSON CrGroup where
toEncoding = genericToEncoding defaultOptions
instance FromJSON CrGroup
deriving (Eq, Ord, Show, Read)
makeLenses ''CreatureState
makeLenses ''CrSpState
makeLenses ''CrGroup
deriveJSON defaultOptions ''CreatureState
deriveJSON defaultOptions ''CreatureDropType
deriveJSON defaultOptions ''CrSpState
deriveJSON defaultOptions ''Faction
deriveJSON defaultOptions ''CrGroup
src/Dodge/Data/Damage.hs
+24 -19
View File
@@ -1,49 +1,54 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-
Datatypes describing the type of damage effects that are to be applied to
creatures.
-}
module Dodge.Data.Damage
( module Dodge.Data.Damage
, module Dodge.Data.Damage.Type
) where
import GHC.Generics
module Dodge.Data.Damage (
module Dodge.Data.Damage,
module Dodge.Data.Damage.Type,
) where
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Dodge.Data.Damage.Type
import Geometry.Data
import Control.Lens
data DamageEffect
= PushDamage
{ _dePush :: Float
, _dePushExp :: Float
, _dePushRadius :: Float
}
| TorqueDamage { _deTorque :: Float }
| PushBackDamage {_dePushBack :: Float }
| TorqueDamage {_deTorque :: Float}
| PushBackDamage {_dePushBack :: Float}
| NoDamageEffect
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON DamageEffect where
toEncoding = genericToEncoding defaultOptions
instance FromJSON DamageEffect
deriving (Eq, Ord, Show, Read)
data Damage = Damage
{ _dmType :: DamageType
, _dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2
, _dmAmount :: Int
, _dmFrom :: Point2
, _dmAt :: Point2
, _dmTo :: Point2
, _dmEffect :: DamageEffect
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Damage where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Damage
deriving (Eq, Ord, Show, Read)
isElectrical :: Damage -> Bool
isElectrical dm = case _dmType dm of
ELECTRICAL -> True
_ -> False
isMovementDam :: Damage -> Bool
isMovementDam dm = case _dmType dm of
TORQUEDAM -> True
PUSHDAM -> True
_ -> False
makeLenses ''Damage
makeLenses ''DamageEffect
deriveJSON defaultOptions ''DamageEffect
deriveJSON defaultOptions ''Damage
src/Dodge/Data/Damage/Type.hs
+10 -6
View File
@@ -1,8 +1,11 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Damage.Type where
import GHC.Generics
import Data.Aeson
import Data.Aeson.TH
data DamageType
= PIERCING
| BLUNT
@@ -19,9 +22,10 @@ data DamageType
| PUSHDAM
| POISONDAM
| ENTERREMENT
deriving (Eq,Ord,Show,Read,Enum,Bounded,Generic)
instance ToJSON DamageType where
toEncoding = genericToEncoding defaultOptions
instance FromJSON DamageType
deriving (Eq, Ord, Show, Read, Enum, Bounded)
instance ToJSONKey DamageType
instance FromJSONKey DamageType
deriveJSON defaultOptions ''DamageType
src/Dodge/Data/Distortion.hs
-1
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data.Distortion where
src/Dodge/Data/Door.hs
+38 -33
View File
@@ -1,47 +1,52 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data.Door where
import GHC.Generics
import Data.Aeson
import Dodge.Data.PathGraph
import Dodge.Data.MountedObject
import Geometry.Data
import Dodge.Data.WorldEffect
import qualified Data.IntSet as IS
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Door (
module Dodge.Data.Door,
module Dodge.Data.MountedObject,
module Dodge.Data.PathGraph,
module Dodge.Data.WorldEffect,
) where
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import qualified Data.IntSet as IS
import Dodge.Data.MountedObject
import Dodge.Data.PathGraph
import Dodge.Data.WorldEffect
import Geometry.Data
data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
deriving (Eq, Ord, Show,Read,Generic)
instance ToJSON DoorStatus where
toEncoding = genericToEncoding defaultOptions
instance FromJSON DoorStatus
data PushSource = PushesItself
deriving (Eq, Ord, Show, Read)
data PushSource
= PushesItself
| PushedBy Int
| NotPushed
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON PushSource where
toEncoding = genericToEncoding defaultOptions
instance FromJSON PushSource
deriving (Eq, Ord, Show, Read)
data Door = Door
{ _drID :: Int
, _drWallIDs :: IS.IntSet
, _drStatus :: DoorStatus
, _drStatus :: DoorStatus
, _drTrigger :: WdBl
, _drMech :: DrWdWd
, _drPos :: (Point2,Point2)
, _drOpenPos :: (Point2,Point2)
, _drClosePos :: (Point2,Point2)
, _drHP :: Int
, _drDeath :: DrWdWd
, _drSpeed :: Float
, _drMech :: DrWdWd
, _drPos :: (Point2, Point2)
, _drOpenPos :: (Point2, Point2)
, _drClosePos :: (Point2, Point2)
, _drHP :: Int
, _drDeath :: DrWdWd
, _drSpeed :: Float
, _drPushedBy :: PushSource
, _drPushes :: Maybe Int
, _drMounts :: [MountedObject]
, _drObstructs :: [(Int,Int,PathEdge)]
, _drObstacleType :: EdgeObstacle
, _drObstructs :: [(Int, Int, PathEdge)]
, _drObstacleType :: EdgeObstacle
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Door where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Door
deriving (Eq, Ord, Show, Read)
makeLenses ''Door
deriveJSON defaultOptions ''DoorStatus
deriveJSON defaultOptions ''PushSource
deriveJSON defaultOptions ''Door
src/Dodge/Data/EnergyBall.hs
+14 -13
View File
@@ -1,25 +1,26 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.EnergyBall where
import GHC.Generics
import Data.Aeson
import Geometry.Data
import Color
import Dodge.Data.Damage.Type
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Dodge.Data.Damage.Type
import Geometry.Data
data EnergyBall = EnergyBall
{ _ebVel :: Point2
, _ebColor :: Color
{ _ebVel :: Point2
, _ebColor :: Color
, _ebPos :: Point2
, _ebWidth :: Float
, _ebTimer :: Int
, _ebEff :: (DamageType,Int)
, _ebEff :: (DamageType, Int)
, _ebZ :: Float
, _ebRot :: Float
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON EnergyBall where
toEncoding = genericToEncoding defaultOptions
instance FromJSON EnergyBall
deriving (Eq, Ord, Show, Read)
makeLenses ''EnergyBall
deriveJSON defaultOptions ''EnergyBall
src/Dodge/Data/Equipment/Misc.hs
+14 -12
View File
@@ -1,9 +1,11 @@
{-# LANGUAGE StrictData #-}
{-# LANGUAGE DeriveGeneric #-}
module Dodge.Data.Equipment.Misc
where
import GHC.Generics
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Equipment.Misc where
import Data.Aeson
import Data.Aeson.TH
data EquipSite
= GoesOnHead
| GoesOnChest
@@ -11,10 +13,8 @@ data EquipSite
| GoesOnWrist
| GoesOnLegs
| GoesOnSpecial
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON EquipSite where
toEncoding = genericToEncoding defaultOptions
instance FromJSON EquipSite
deriving (Eq, Ord, Show, Read)
data EquipPosition
= OnHead
| OnChest
@@ -23,9 +23,11 @@ data EquipPosition
| OnRightWrist
| OnLegs
| OnSpecial
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON EquipPosition where
toEncoding = genericToEncoding defaultOptions
instance FromJSON EquipPosition
deriving (Eq, Ord, Show, Read)
instance ToJSONKey EquipPosition
instance FromJSONKey EquipPosition
deriveJSON defaultOptions ''EquipSite
deriveJSON defaultOptions ''EquipPosition
src/Dodge/Data/Flame.hs
+17 -16
View File
@@ -1,23 +1,24 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Flame where
import GHC.Generics
import Data.Aeson
import Control.Lens
import Geometry.Data
import Color
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Geometry.Data
data Flame = Flame
{ _flVel :: Point2
, _flColor :: Color
, _flPos :: Point2
, _flWidth :: Float
, _flTimer :: Int
, _flZ :: Float
{ _flVel :: Point2
, _flColor :: Color
, _flPos :: Point2
, _flWidth :: Float
, _flTimer :: Int
, _flZ :: Float
, _flOriginalVel :: Point2
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Flame where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Flame
deriving (Eq, Ord, Show, Read)
makeLenses ''Flame
deriveJSON defaultOptions ''Flame
src/Dodge/Data/Flare.hs
+18 -17
View File
@@ -1,27 +1,28 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.Flare where
import GHC.Generics
import Data.Aeson
import Color
import Geometry
import Control.Lens
import Data.Aeson
import Data.Aeson.TH
import Geometry
data Flare
= MuzFlare
{ _flarePoly :: [Point2]
, _flareColor :: Color
, _flareTran3 :: Point3
, _flareTime :: Int
{ _flarePoly :: [Point2]
, _flareColor :: Color
, _flareTran3 :: Point3
, _flareTime :: Int
}
| CircFlare
{ _flareColor :: Color
, _flareAlpha :: Float
, _flareTran3 :: Point3
, _flareTime :: Int
{ _flareColor :: Color
, _flareAlpha :: Float
, _flareTran3 :: Point3
, _flareTime :: Int
}
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON Flare where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Flare
deriving (Eq, Ord, Show, Read)
makeLenses ''Flare
deriveJSON defaultOptions ''Flare
src/Dodge/Data/FloatFunction.hs
+11 -7
View File
@@ -1,13 +1,17 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Dodge.Data.FloatFunction where
import GHC.Generics
import Data.Aeson
data FloatFloat = FloatID
import Data.Aeson.TH
data FloatFloat
= FloatID
| FloatFOV Float
| FloatLessCheck Float
| FloatAbsCheckGreaterLess Float Float Float
| FloatConst Float
deriving (Eq,Ord,Show,Read,Generic)
instance ToJSON FloatFloat where
toEncoding = genericToEncoding defaultOptions
instance FromJSON FloatFloat
deriving (Eq, Ord, Show, Read)
deriveJSON defaultOptions ''FloatFloat

Some files were not shown because too many files have changed in this diff Show More