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

Add trajectory to grenades, various refactoring

Browse Source
This commit is contained in:
justin
2021-09-25 18:39:53 +01:00
parent a0340eb024
commit 32367b5b2d
32 changed files with 339 additions and 253 deletions
Download Patch File Download Diff File Expand all files Collapse all files
shader/lighting/occlude.frag → shader/lighting/wallShadow.frag
View File
shader/lighting/occlude.geom → shader/lighting/wallShadow.geom
View File
shader/lighting/occlude.vert → shader/lighting/wallShadow.vert
View File
src/Data/Preload/Render.hs
+1 -3
View File
@@ -12,9 +12,7 @@ import qualified Data.Vector.Mutable as MV
import Control.Monad.Primitive
data RenderData = RenderData
{ _lightingOccludeShader :: FullShader
--, _lightingWallShader :: FullShader
--, _lightingSurfaceShader :: FullShader
{ _lightingWallShadShader :: FullShader
, _lightingLineShadowShader :: FullShader
, _lightingCapShader :: FullShader
, _wallBlankShader :: FullShader
src/Dodge/Base.hs
+3 -3
View File
@@ -151,7 +151,7 @@ adjustIMZone f x y n = IM.adjust f' x
f'' = IM.adjust f n
{- | Finds unused projectile key. -}
newProjectileKey :: World -> Int
newProjectileKey = IM.newKey . _projectiles
newProjectileKey = IM.newKey . _props
{- | Finds unused creature key. -}
newCrKey :: World -> Int
newCrKey = IM.newKey . _creatures
@@ -256,8 +256,8 @@ collideCircWalls' p1 p2 rad = either (const Nothing) Just . foldr findPoint (Lef
-- | Looks for first collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
collideCircWalls'' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
collideCircWalls'' p1 p2 rad ws
collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
collideCircWalls p1 p2 rad ws
= safeMinimumOn (dist p1 . fst)
$ IM.mapMaybe
(( \(x:y:_) -> fmap
src/Dodge/Creature.hs
+1
View File
@@ -162,6 +162,7 @@ startInventory :: IM.IntMap Item
startInventory = IM.fromList (zip [0..20]
(
[spreadGun
,longGun
,autoGun
,ltAutoGun
,hvAutoGun
src/Dodge/Creature/Picture.hs
+4 -4
View File
@@ -53,7 +53,7 @@ basicCrShape
-> Shape
basicCrShape col cr = tr $ mconcat
[ rotdir . _spShape $ drawEquipment cr
, rotdir . dm . translateSHz 25 $ scalp cr
, rotdir . dm . translateSHz 20 $ scalp cr
, rotdir . dm $ upperBody col cr
, dm . rotmdir $ feet cr
]
@@ -164,7 +164,7 @@ arms cr
_ -> emptySH
where
aHand :: Shape
aHand = translateSHz (-4) . upperPrismPoly 4 $ polyCirc 3 4
aHand = translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4
crad = _crRad cr
off = 8
sLen = _strideLength $ _crStance cr
@@ -177,7 +177,7 @@ scalp cr
| oneH cr = rotateSH 0.5 $ translateSHf (0.25 * crad) 0 fhead
| otherwise = translateSHf (0.25 * crad) 0 fhead
where
fhead = colorSH (greyN 0.9) . upperPrismPoly 5 . polyCirc 3 $ crad * 0.5
fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 . polyCirc 4 $ crad * 0.5
crad = _crRad cr
oneH :: Creature -> Bool
@@ -212,7 +212,7 @@ torso cr
baseShoulder :: Shape
{-# INLINE baseShoulder #-}
baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPoly 10 $ polyCirc 3 1
baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalf 10 $ polyCirc 3 1
upperBody :: Color -> Creature -> Shape
{-# INLINE upperBody #-}
src/Dodge/Data.hs
+23 -11
View File
@@ -56,7 +56,7 @@ data World = World
, _itemPositions :: IM.IntMap ItemPos
, _clouds :: [Cloud]
, _cloudsZone :: Zone [Cloud]
, _projectiles :: IM.IntMap Projectile
, _props :: IM.IntMap Prop
, _particles :: ![Particle]
, _walls :: !(IM.IntMap Wall)
, _wallsZone :: Zone (IM.IntMap Wall)
@@ -455,7 +455,7 @@ data Ammo
{ _amPayload :: Point2 -> World -> World
, _amString :: String
, _amPjParams :: [PjParam]
, _amPjDraw :: Projectile -> Picture
, _amPjDraw :: Prop -> SPic
, _amParamSel :: Int
}
| BulletAmmo
@@ -466,19 +466,19 @@ data Ammo
}
| GenericAmmo
data PjParam = PjParam
{ _pjMoveParam :: Int -> Item -> Creature -> Projectile -> World -> World
{ _pjMoveParam :: Int -> Item -> Creature -> Prop -> World -> World
, _pjIntParam :: Int
, _pjMaxParam :: Int
, _pjDisplayParam :: Int -> String
}
data Projectile
data Prop
= Projectile
{ _pjPos :: Point2
, _pjStartPos :: Point2
, _pjVel :: Point2
, _pjDraw :: Projectile -> Picture
, _prDraw :: Prop -> SPic
, _pjID :: Int
, _pjUpdate :: Projectile -> World -> World
, _pjUpdate :: Prop -> World -> World
}
| Shell
{ _pjPos :: Point2
@@ -487,16 +487,28 @@ data Projectile
, _pjAcc :: Point2
, _pjDir :: Float
, _pjSpin :: Float
, _pjDraw :: Projectile -> Picture
, _prDraw :: Prop -> SPic
, _pjID :: Int
, _pjUpdate :: Projectile -> World -> World
, _pjUpdate :: Prop -> World -> World
, _pjPayload :: Point2 -> World -> World
, _pjTimer :: Int
, _pjZ :: Float
}
| Bomb
{ _pjPos :: Point2
, _pjVel :: Point2
, _pjZ :: Float
, _pjVelZ :: Float
, _prDraw :: Prop -> SPic
, _pjID :: Int
, _pjUpdate :: Prop -> World -> World
, _pjPayload :: Point2 -> World -> World
, _pjTimer :: Int
}
| LinearShockwave
{ _pjDraw :: Projectile -> Picture
{ _prDraw :: Prop -> SPic
, _pjID :: Int
, _pjUpdate :: Projectile -> World -> World
, _pjUpdate :: Prop -> World -> World
, _pjPoints :: [(Point2,Point2)]
, _pjTimer :: Int
}
@@ -720,7 +732,7 @@ makeLenses ''ItZoom
makeLenses ''FloorItem
makeLenses ''Ammo
makeLenses ''PjParam
makeLenses ''Projectile
makeLenses ''Prop
makeLenses ''Particle
makeLenses ''Wall
makeLenses ''ForceField
src/Dodge/Debug.hs
+11 -11
View File
@@ -14,45 +14,45 @@ import qualified Data.IntSet as IS
import Control.Lens
drawCircleAtFor :: Point2 -> Int -> World -> World
drawCircleAtFor p t w = w & projectiles %~
drawCircleAtFor p t w = w & props %~
IM.insert k Projectile
{ _pjPos = p
, _pjStartPos = p
, _pjVel = V2 0 0
, _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color white $ circleSolid 20
, _prDraw = \_ -> (,) mempty $ onLayer PtLayer $ uncurryV translate p $ color white $ circleSolid 20
, _pjID = k
, _pjUpdate = \_ -> pjTimerF t k
}
where
k = IM.newKey $ _projectiles w
k = IM.newKey $ _props w
drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World
drawCircleAtForCol p t col w = w & projectiles %~
drawCircleAtForCol p t col w = w & props %~
IM.insert k Projectile
{ _pjPos = p
, _pjStartPos = p
, _pjVel = V2 0 0
, _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ color col $ circleSolid 20
, _prDraw = \_ -> (,) mempty $ onLayer PtLayer $ uncurryV translate p $ color col $ circleSolid 20
, _pjID = k
, _pjUpdate = \_ -> pjTimerF t k
}
where
k = IM.newKey $ _projectiles w
k = IM.newKey $ _props w
drawLineForCol :: [Point2] -> Int -> Color -> World -> World
drawLineForCol ps t col w = w & projectiles %~
drawLineForCol ps t col w = w & props %~
IM.insert k Projectile
{ _pjPos = head ps
, _pjStartPos = head ps
, _pjVel = V2 0 0
, _pjDraw = \_ -> onLayer PtLayer $ color col $ lineOfThickness 5 ps
, _prDraw = \_ -> (,) mempty $ onLayer PtLayer $ color col $ lineOfThickness 5 ps
, _pjID = k
, _pjUpdate = \_ -> pjTimerF t k
}
where
k = IM.newKey $ _projectiles w
k = IM.newKey $ _props w
pjTimerF :: Int -> Int -> World -> World
pjTimerF 0 i = projectiles %~ IM.delete i
pjTimerF time i = projectiles . ix i . pjUpdate .~ (\_ -> pjTimerF (time - 1) i)
pjTimerF 0 i = props %~ IM.delete i
pjTimerF time i = props . ix i . pjUpdate .~ (\_ -> pjTimerF (time - 1) i)
drawDDA :: IM.IntMap IS.IntSet -> Picture
drawDDA = setLayer 1 . color (withAlpha 0.5 green) . IM.foldlWithKey' f blank
src/Dodge/Default.hs
+2 -2
View File
@@ -221,12 +221,12 @@ defaultButton = Button
, _btText = "Button"
, _btState = BtOff
}
defaultPT :: Projectile
defaultPT :: Prop
defaultPT = Projectile
{ _pjPos = V2 0 0
, _pjStartPos = V2 0 0
, _pjVel = V2 0 0
, _pjDraw = const blank
, _prDraw = const mempty
, _pjID = 0
, _pjUpdate = const id
}
src/Dodge/Default/Shell.hs
+3 -2
View File
@@ -4,15 +4,16 @@ import Dodge.Data
import Picture
import Geometry.Data
defaultShell :: Projectile
defaultShell :: Prop
defaultShell = Shell
{ _pjPos = V2 0 0
, _pjZ = 20
, _pjStartPos = V2 0 0
, _pjVel = V2 0 0
, _pjAcc = V2 0 0
, _pjDir = 0
, _pjSpin = 0
, _pjDraw = const blank
, _prDraw = const (mempty, blank)
, _pjID = 0
, _pjTimer = 0
, _pjUpdate = const id
src/Dodge/Default/Weapon.hs
+1 -1
View File
@@ -58,6 +58,6 @@ defaultShellAmmo = ShellAmmo
{ _amPayload = const id
, _amString = "Shell"
, _amPjParams = []
, _amPjDraw = const blank
, _amPjDraw = const mempty
, _amParamSel = 0
}
src/Dodge/Default/World.hs
+1 -1
View File
@@ -33,7 +33,7 @@ defaultWorld = World
, _clouds = []
, _cloudsZone = Zone IM.empty
, _itemPositions = IM.empty
, _projectiles = IM.empty
, _props = IM.empty
, _particles = []
, _walls = IM.empty
, _wallsZone = Zone IM.empty
src/Dodge/Initialisation.hs
+1 -1
View File
@@ -42,7 +42,7 @@ initialWorld = defaultWorld
, _cameraRot = 0
, _cameraZoom = 10
, _creatures = IM.fromList [(0,startCr)]
, _projectiles = IM.empty
, _props = IM.empty
, _walls = IM.empty
, _forceFields = IM.empty
, _floorItems = IM.empty
src/Dodge/Item/Weapon.hs
+38 -37
View File
@@ -688,11 +688,11 @@ aTeslaArc cr w
chooseColor 2 = blue
chooseColor _ = cyan
remoteShellPic' :: Projectile -> Picture
remoteShellPic' pj
| t > 40 = onLayerL [levLayer CrLayer - 2]
remoteShellDraw :: Prop -> SPic
remoteShellDraw pj
| t > 40 = (,) mempty $ onLayerL [levLayer CrLayer - 2]
$ uncurryV translate pos $ rotate dir $ remoteShellPic t
| otherwise = uncurryV translate pos $ rotate dir $ remoteShellPic t
| otherwise = (,) mempty $ uncurryV translate pos $ rotate dir $ remoteShellPic t
where
t = _pjTimer pj
pos = _pjPos pj
@@ -751,16 +751,16 @@ retireRemoteRocket :: Int -> Int -> Int -> World -> World
retireRemoteRocket itid 0 pjid w =
set (pointToItem (_itemPositions w IM.! itid) . itAttachment . scopePos) (V2 0 0)
$ set (pointToItem (_itemPositions w IM.! itid) . itUse) (const fireRemoteLauncher)
(w & projectiles %~ IM.delete pjid)
(w & props %~ IM.delete pjid)
retireRemoteRocket itid t pjid w = setScope w
& projectiles . ix pjid . pjUpdate .~ (\_ -> retireRemoteRocket itid (t-1) pjid)
& props . ix pjid . pjUpdate .~ (\_ -> retireRemoteRocket itid (t-1) pjid)
where
setScope w' = case _itemPositions w' IM.! itid of
InInv cid invid -> w'
& creatures . ix cid . crInv . ix invid . itAttachment
. scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid))
_ -> w'
pos = fromMaybe (V2 0 0) $ w ^? projectiles . ix pjid . pjPos
pos = fromMaybe (V2 0 0) $ w ^? props . ix pjid . pjPos
retireRemoteBomb :: Int -> Int -> Int -> World -> World
retireRemoteBomb itid 0 pjid w = w
& pointToItem (_itemPositions w IM.! itid) %~
@@ -768,21 +768,21 @@ retireRemoteBomb itid 0 pjid w = w
. (itZoom .~ defaultItZoom)
. (itUse .~ const throwRemoteBomb)
)
& projectiles %~ IM.delete pjid
& props %~ IM.delete pjid
retireRemoteBomb itid t pjid w = setScope w
& projectiles . ix pjid . pjUpdate .~ (\_ -> retireRemoteBomb itid (t-1) pjid)
& props . ix pjid . pjUpdate .~ (\_ -> retireRemoteBomb itid (t-1) pjid)
where
setScope w' = case _itemPositions w' IM.! itid of
InInv cid invid -> w'
& creatures . ix cid . crInv . ix invid . itAttachment
. scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid))
_ -> w'
pos = fromMaybe (V2 0 0) $ w ^? projectiles . ix pjid . pjPos
pos = fromMaybe (V2 0 0) $ w ^? props . ix pjid . pjPos
moveRemoteBomb :: Int -> Int -> Int -> World -> World
moveRemoteBomb itid time pID w
| time < -4 = updatePicture
$ set (projectiles .ix pID.pjUpdate) (\_ -> moveRemoteBomb itid (f time) pID)
$ set (props .ix pID.pjUpdate) (\_ -> moveRemoteBomb itid (f time) pID)
w
| time < 2 = case hitWl of
Just (p,_) -> soundStart (Tap 0) p tapQuietS Nothing $ halfV updatedWorld
@@ -792,40 +792,40 @@ moveRemoteBomb itid time pID w
_ -> updatedWorld
where
updatedWorld
= updateV $ set (projectiles . ix pID . pjPos) finalPos
= updateV $ set (props . ix pID . pjPos) finalPos
$ updatePicture
$ set (projectiles .ix pID.pjUpdate) (\_ -> moveRemoteBomb itid (time-1) pID)
$ set (props .ix pID.pjUpdate) (\_ -> moveRemoteBomb itid (time-1) pID)
w
pj = _projectiles w IM.! pID
pj = _props w IM.! pID
oldPos = _pjPos pj
newPos = _pjVel pj +.+ oldPos
-- this is hacky, should use a version of collidePointWalls' that collides
-- circles and walls
invShift x = x -.- 5 *.* normalizeV (_pjVel pj)
hitWl = collideCircWalls'' oldPos newPos 4 $ wallsNearPoint newPos w
hitWl = collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w
finalPos = maybe newPos (invShift . fst) hitWl
setV v = set (projectiles . ix pID . pjVel) v
setV v = set (props . ix pID . pjVel) v
updateV = maybe id (setV . snd) hitWl
halfV = projectiles . ix pID . pjVel %~ (0.5 *.*)
halfV = props . ix pID . pjVel %~ (0.5 *.*)
f x | x < -369 = -10
| otherwise = x - 1
updatePicture =
set (projectiles . ix pID . pjDraw)
(\_ -> onLayer PtLayer $ uncurryV translate newPos $ remoteBombPic time)
set (props . ix pID . prDraw)
(\_ -> (,) mempty $ onLayer PtLayer $ uncurryV translate newPos $ remoteBombPic time)
. lowLightDirected
(withAlpha 0.1 red)
newPos
(50 *.* unitVectorAtAngle (negate $ degToRad (10 * fromIntegral time)))
[-0.2,-0.15,-0.1,-0.05,0,0.05,0.1,0.15,0.2]
setRemoteScope :: Int -> Projectile -> World -> World
setRemoteScope :: Int -> Prop -> World -> World
setRemoteScope itid pj w' = case w' ^? itemPositions . ix itid of
Just (InInv cid' invid )
-> w' & creatures . ix cid' . crInv . ix invid . itAttachment
. scopePos .~ (_pjPos pj -.- _crPos (_creatures w' IM.! cid'))
_ -> w'
setRemoteBombScope :: Int -> Projectile -> World -> World
setRemoteBombScope :: Int -> Prop -> World -> World
setRemoteBombScope itid pj w' = case _itemPositions w' IM.! itid of
InInv cid invid
-> w' & creatures . ix cid . crInv . ix invid . itAttachment
@@ -909,17 +909,18 @@ fireRemoteLauncher cr w = setLocation
$ resetFire
$ resetName
$ soundStart (CrWeaponSound cid 0) pos tap4S Nothing
$ over projectiles addRemRocket w
$ over props addRemRocket w
where
i = IM.newKey $ _projectiles w
i = IM.newKey $ _props w
cid = _crID cr
dir = _crDir cr
pos = _crPos cr +.+ rotateV dir (V2 (_crRad cr + 1) 0)
addRemRocket = IM.insert i $ Shell
{ _pjPos = pos
, _pjZ = 20
, _pjStartPos = pos
, _pjVel = rotateV dir (V2 1 0)
, _pjDraw = remoteShellPic'
, _prDraw = remoteShellDraw
, _pjID = i
, _pjUpdate = \pj -> decTimMvVel pj . setRemoteScope itid pj . moveRemoteShell cid itid pj
, _pjAcc = V2 0 0
@@ -941,18 +942,18 @@ fireRemoteLauncher cr w = setLocation
_ -> w'
itid = fromMaybe newitid maybeitid
moveRemoteShell :: Int -> Int -> Projectile -> World -> World
moveRemoteShell :: Int -> Int -> Prop -> World -> World
moveRemoteShell cid itid pj w
| time > 40 = if circOnSomeWall oldPos 4 w
then doExplosion w
else w
| time >= 20 = case thingHit of
Just _ -> doExplosion w
Nothing -> w & projectiles . ix i . pjDir .~ newdir
Nothing -> w & props . ix i . pjDir .~ newdir
| time > -99 = case thingHit of
Just _ -> doExplosion $ stopSoundFrom (ShellSound i) w
Nothing -> w & set randGen g
& projectiles . ix i %~
& props . ix i %~
( ( pjVel %~ ( (accel +.+) . (frict *.*) ) )
. ( pjDir .~ newdir )
)
@@ -978,7 +979,7 @@ moveRemoteShell cid itid pj w
(frict,g) = randomR (0.6,0.9) $ _randGen w
(sparkD,_) = randomR (-0.5,0.5) $ _randGen w
hitCr = fst <$> collideCircCrsPoint oldPos newPos 4 w
hitWl = fst <$> collideCircWalls'' oldPos newPos 2 (wallsNearPoint newPos w)
hitWl = fst <$> collideCircWalls oldPos newPos 2 (wallsNearPoint newPos w)
thingHit = hitCr <|> hitWl
r1 = _randGen w & evalState (randInCirc 10)
smokeGen = shellTrailCloud $ addZ 20 $ oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos)
@@ -990,11 +991,11 @@ explodeRemoteRocket
-> World
-> World
explodeRemoteRocket itid pjid w
= set (projectiles . ix pjid . pjUpdate) (\_ -> retireRemoteRocket itid 30 pjid)
$ set (projectiles . ix pjid . pjDraw) (const blank)
= set (props . ix pjid . pjUpdate) (\_ -> retireRemoteRocket itid 30 pjid)
$ set (props . ix pjid . prDraw) (const mempty)
$ set (itPoint . itUse) (\_ _ -> id)
$ resetName
$ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w
$ makeExplosionAt (_pjPos (_props w IM.! pjid)) w
where
resetName = set (itPoint . itName) "REMOTELAUNCHER"
itPoint = pointToItem $ _itemPositions w IM.! itid
@@ -1004,14 +1005,14 @@ throwRemoteBomb cr w = setLocation
$ removePict
$ resetFire
$ resetName
$ over projectiles addG w
$ over props addG w
where
cid = _crID cr
addG = IM.insert i $ Projectile
{ _pjPos = p
, _pjStartPos = p
, _pjVel = v
, _pjDraw = const blank
, _prDraw = const mempty
, _pjID = i
, _pjUpdate = \_ -> moveRemoteBomb itid 50 i
}
@@ -1038,14 +1039,14 @@ throwRemoteBomb cr w = setLocation
explodeRemoteBomb :: Int -> Int -> Creature -> World -> World
explodeRemoteBomb itid pjid cr w
= set (projectiles . ix pjid . pjUpdate) (\_ -> retireRemoteBomb itid 30 pjid)
-- $ set (projectiles . ix pjid . pjDraw) (\_ -> blank)
= set (props . ix pjid . pjUpdate) (\_ -> retireRemoteBomb itid 30 pjid)
-- $ set (props . ix pjid . pjDraw) (\_ -> blank)
$ set (creatures . ix cid . crInv . ix j . itUse) (\_ -> const id)
$ resetName
$ resetPict
-- $ resetScope
$ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w
-- - $ makeShrapnelBombAt (_pjPos (_projectiles w IM.! pjid)) w
$ makeExplosionAt (_pjPos (_props w IM.! pjid)) w
-- - $ makeShrapnelBombAt (_pjPos (_props w IM.! pjid)) w
where
cid = _crID cr
resetName = set (creatures . ix cid . crInv . ix j . itName) "REMOTEBOMB"
src/Dodge/Item/Weapon/AutoGun.hs
+4 -1
View File
@@ -15,6 +15,7 @@ import Dodge.Item.Weapon.TriggerType
import Dodge.SoundLogic.LoadSound
import Picture
import Geometry
import Geometry.Vector3D
import ShapePicture
import Shape
@@ -64,7 +65,9 @@ autoGun = defaultAutoGun
}
autoGunPic :: SPic
autoGunPic =
( colorSH red $ upperPrismPoly 5 $ rectNESW 4 12 (-4) (-12)
( colorSH red $ prismPoly
(map (addZ 5) $ rectNESW 2 12 (-2) (-12))
(map (addZ 0) $ rectNESW 4 12 (-4) (-12))
, mempty
)
src/Dodge/Item/Weapon/Booster.hs
+9 -8
View File
@@ -9,6 +9,7 @@ import qualified IntMapHelp as IM
import Dodge.Picture.Layer
import Picture
import Dodge.Item.Attachment.Data
import ShapePicture
import Data.Maybe
import Control.Lens
@@ -40,7 +41,7 @@ boostSelfL x cr invid w = case boostPoint x cr w of
cid = _crID cr
cpos = _crPos cr
r = _crRad cr
pid = fromMaybe (IM.newKey $ _projectiles w)
pid = fromMaybe (IM.newKey $ _props w)
(cr ^? crInv . ix invid . itAttachment . itInt)
crEff p ammoEff = addBoostShockwave pid p (r *.* normalizeV (p -.- cpos)) w
& creatures . ix cid %~
@@ -64,11 +65,11 @@ addBoostShockwave
-> Point2
-> World
-> World
addBoostShockwave pjid p v w = w & projectiles %~
addBoostShockwave pjid p v w = w & props %~
IM.insertWith f pjid thePJ
where
thePJ = LinearShockwave
{ _pjDraw = drawBoostShockwave
{ _prDraw = drawBoostShockwave
, _pjID = pjid
, _pjUpdate = updateLinearShockwave
, _pjPoints = [(p,v)]
@@ -76,16 +77,16 @@ addBoostShockwave pjid p v w = w & projectiles %~
}
f newVal oldVal = newVal & pjPoints %~ (++ _pjPoints oldVal)
updateLinearShockwave :: Projectile -> World -> World
updateLinearShockwave :: Prop -> World -> World
updateLinearShockwave pj w
| t < 1 = w & projectiles %~ IM.delete pjid
| otherwise = w & projectiles . ix (_pjID pj) . pjTimer -~ 1
| t < 1 = w & props %~ IM.delete pjid
| otherwise = w & props . ix (_pjID pj) . pjTimer -~ 1
where
pjid = _pjID pj
t = _pjTimer pj
drawBoostShockwave :: Projectile -> Picture
drawBoostShockwave pj = setLayer 1 $ onLayer UPtLayer $ pictures $
drawBoostShockwave :: Prop -> SPic
drawBoostShockwave pj = (,) mempty $ setLayer 1 $ onLayer UPtLayer $ pictures $
theArc ++
[ lineCol $ zip (reverse lps) $ map (`withAlpha` white) [0,0.05..]
, lineCol $ zip (reverse rps) $ map (`withAlpha` white) [0,0.05..]
src/Dodge/Item/Weapon/ExtraEffect.hs
+1 -1
View File
@@ -32,7 +32,7 @@ wpRecock = ItInvEffect
}
where
f _ cr i = creatures . ix (_crID cr) . crInv %~ IM.adjust fOnIt i
moveHammerUp HammerDown = HammerReleased
moveHammerUp HammerDown = HammerReleased
moveHammerUp HammerReleased = HammerUp
moveHammerUp HammerUp = HammerUp
moveHammerUp NoHammer = NoHammer
src/Dodge/Item/Weapon/Grenade.hs
+40 -43
View File
@@ -5,12 +5,10 @@ import Dodge.Data.SoundOrigin
import Dodge.Item.Data
import Dodge.Base
import Dodge.Zone
import Dodge.Picture.Layer
import Dodge.SoundLogic
import Dodge.SoundLogic.LoadSound
import Dodge.Item.Attachment.Data
import Dodge.Item.Draw
import Dodge.Default.Shell
--import Dodge.Default
import Picture
import Geometry
@@ -19,64 +17,63 @@ import Shape
import Control.Lens
import qualified Data.IntMap.Strict as IM
--import System.Random
moveGrenade
:: Int -- ^ Timer
-> Float -- ^ Direction
-> Int -- ^ Projectile id
-> World
-> World
moveGrenade 0 _ pID w = over projectiles (IM.delete pID)
$ explosion (_pjPos (_projectiles w IM.! pID))
w
where
pj = _projectiles w IM.! pID
explosion = _pjPayload pj
moveGrenade time dir pID w = case hitWl of
Just (p,_) -> soundStart (Tap 0) p tapQuietS Nothing updatedWorld
_ -> updatedWorld
moveGrenade :: Prop -> World -> World
moveGrenade pj w
| _pjTimer pj <= 0 = w
& props %~ IM.delete pID
& (_pjPayload pj) (_pjPos (_props w IM.! pID))
| otherwise = case collideCircWalls oldPos newPos 4 $ wallsNearPoint newPos w of
Nothing -> w & props . ix pID %~ normalUpdate
Just (p,v) -> w
& soundStart (Tap 0) p tapQuietS Nothing
& props . ix pID %~ ( ( pjPos .~ p ) . ( pjTimer -~ 1 ) . (pjVel .~ v) )
where
updatedWorld = updateV $ set (projectiles . ix pID . pjPos) finalPos
$ set (projectiles .ix pID. pjDraw)
(\ _ -> onLayer PtLayer $ uncurryV translate newPos
$ rotate dir $ _spPicture $ grenadePic time)
$ set (projectiles .ix pID.pjUpdate) (\_ -> moveGrenade (time-1) dir pID) w
pj = _projectiles w IM.! pID
pID = _pjID pj
normalUpdate = (pjTimer -~ 1)
. (pjZ %~ (max 0 . (+ _pjVelZ pj)))
. (pjVelZ -~ 0.1)
. ( pjPos .~ newPos )
oldPos = _pjPos pj
newPos = _pjVel pj +.+ oldPos
hitWl = collideCircWalls'' oldPos newPos 4 $ wallsNearPoint newPos w
finalPos = maybe newPos fst hitWl
setV v = set (projectiles .ix pID.pjVel) v
updateV = maybe id (setV . snd) hitWl
grenadePic :: Int -> SPic
grenadePic x = (,) emptySH $ pictures
[ color (dark $ dark green) $ circleSolid 5
, color green $ arc (degToRad $ (179 * fromIntegral x / 50) - 180 )
(degToRad $ 180 - (179 * fromIntegral x / 50) )
5
, translate (-2) 2 $ rotate (pi*0.5)
$ scale 0.05 0.05 $ color green $ text $ show $ 1 + quot x 20
]
grenadePic time =
( colorSH (dark $ dark green) $ upperPrismPolyHalf 5 $ polyCirc 3 5
, pictures
[ color green $ arc (degToRad $ (179 * fromIntegral time / 50) - 180 )
(degToRad $ 180 - (179 * fromIntegral time / 50) )
5
-- , translate (-2) 2 $ rotate (pi*0.5)
-- $ scale 0.05 0.05 $ color green $ text $ show $ 1 + quot time 20
]
)
grenadeDraw :: Float -> Prop -> SPic
grenadeDraw dir prop = translateSPz z $ uncurryV translateSPf p $ rotateSP dir $ grenadePic time
where
p = _pjPos prop
time = _pjTimer prop
z = _pjZ prop
throwGrenade
:: (Point2 -> World -> World) -- ^ Payload
-> Creature
-> World
-> World
throwGrenade explosion cr w = setWp $ removePict $ over projectiles addG w
throwGrenade thePayload cr w = setWp $ removePict $ over props addG w
where
n = _crID cr
addG = IM.insert i $ defaultShell
addG = IM.insert i $ Bomb
{ _pjPos = p
, _pjStartPos = p
, _pjZ = 10
, _pjVelZ = 2
, _pjVel = v
, _pjDraw = \_ -> onLayer PtLayer $ uncurryV translate p $ _spPicture $ grenadePic 0
, _prDraw = grenadeDraw dir
, _pjID = i
, _pjUpdate = \_ -> moveGrenade fuseTime dir i
, _pjPayload = explosion
, _pjUpdate = moveGrenade
, _pjPayload = thePayload
, _pjTimer = fuseTime
}
j = _crInvSel cr
removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> (,) emptySH blank
src/Dodge/Item/Weapon/Launcher.hs
+19 -19
View File
@@ -100,17 +100,17 @@ thrustParam = PjParam
, _pjMaxParam = 5
}
pjThrust :: Int -> Projectile -> World -> World
pjThrust :: Int -> Prop -> World -> World
pjThrust i = pjEffTimeRange (st,et) doThrust
where
et | i == 0 = 36
| otherwise = 40 - (i * 20)
st = et - 100
doThrust :: Projectile -> World -> World
doThrust :: Prop -> World -> World
doThrust pj w = w
& randGen .~ g
& projectiles . ix i . pjVel %~ (\v -> accel +.+ frict *.* v)
& props . ix i . pjVel %~ (\v -> accel +.+ frict *.* v)
& soundContinue (ShellSound i) newPos missileLaunchS (Just 1)
& makeFlameletTimed (oldPos -.- vel) 0 (vel +.+ rotateV (pi+sparkD) accel) Nothing 3 10
& smokeGen
@@ -137,10 +137,10 @@ aRocketWithItemParams
-> Creature
-> World
-> World
aRocketWithItemParams it cr w = over projectiles (IM.insert i theShell) w
aRocketWithItemParams it cr w = over props (IM.insert i theShell) w
where
am = _wpAmmo it
i = IM.newKey $ _projectiles w
i = IM.newKey $ _props w
pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir)
dir = _crDir cr
ammoMvs pj w' = foldr (\pjP -> _pjMoveParam pjP (_pjIntParam pjP) it cr pj) w' (_amPjParams am)
@@ -149,7 +149,7 @@ aRocketWithItemParams it cr w = over projectiles (IM.insert i theShell) w
, _pjStartPos = pos
, _pjVel = rotateV dir (V2 1 0)
, _pjAcc = rotateV dir (V2 3 0)
, _pjDraw = _amPjDraw am
, _prDraw = _amPjDraw am
, _pjID = i
, _pjUpdate = \pj -> ammoMvs pj . decTimMvVel pj . moveShell pj
, _pjPayload = _amPayload am
@@ -157,7 +157,7 @@ aRocketWithItemParams it cr w = over projectiles (IM.insert i theShell) w
}
moveShell
:: Projectile -- ^ Projectile id
:: Prop -- ^ Projectile id
-> World
-> World
moveShell pj w
@@ -172,21 +172,21 @@ moveShell pj w
doExplode = w
& projectileExplosion oldPos
& stopSoundFrom (ShellSound i)
& projectiles %~ IM.delete i
& props %~ IM.delete i
i = _pjID pj
oldPos = _pjPos pj
vel = _pjVel pj
projectileExplosion = _pjPayload pj
newPos = oldPos +.+ vel
hitCr = fst <$> collideCircCrsPoint oldPos newPos 4 w
hitWl = fst <$> collideCircWalls'' oldPos newPos 2 (wallsNearPoint newPos w)
hitWl = fst <$> collideCircWalls oldPos newPos 2 (wallsNearPoint newPos w)
thingHit = hitCr <|> hitWl
reduceSpinBy :: Float -> Projectile -> World -> World
reduceSpinBy x pj = projectiles . ix (_pjID pj) . pjSpin *~ x
reduceSpinBy :: Float -> Prop -> World -> World
reduceSpinBy x pj = props . ix (_pjID pj) . pjSpin *~ x
shellPic :: Projectile -> Picture
shellPic pj = setDepth 20 . uncurryV translate pos $ rotate (argV accel) basePic
shellPic :: Prop -> SPic
shellPic pj = (,) mempty $ setDepth 20 . uncurryV translate pos $ rotate (argV accel) basePic
where
basePic = color black $ polygon $ map toV2 [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
accel = _pjAcc pj
@@ -194,8 +194,8 @@ shellPic pj = setDepth 20 . uncurryV translate pos $ rotate (argV accel) basePic
pjEffTimeRange
:: (Int,Int)
-> (Projectile -> World -> World)
-> Projectile
-> (Prop -> World -> World)
-> Prop
-> World
-> World
pjEffTimeRange (st,et) f pj
@@ -206,8 +206,8 @@ pjEffTimeRange (st,et) f pj
pjEffAtTime
:: Int
-> (Projectile -> World -> World)
-> Projectile
-> (Prop -> World -> World)
-> Prop
-> World
-> World
pjEffAtTime t f pj
@@ -217,10 +217,10 @@ pjEffAtTime t f pj
trySpinByCID
:: Int -- ^ creature id
-> Int -- ^ Spin amount
-> Projectile
-> Prop
-> World
-> World
trySpinByCID cid i pj w = w & projectiles . ix pjid . pjSpin .~ newSpin
trySpinByCID cid i pj w = w & props . ix pjid . pjSpin .~ newSpin
where
pjid = _pjID pj
dir = argV $ _pjVel pj
src/Dodge/Item/Weapon/Shell.hs
+2 -2
View File
@@ -4,8 +4,8 @@ import Dodge.Data
import Geometry.Vector
import Control.Lens
decTimMvVel :: Projectile -> World -> World
decTimMvVel pj = projectiles . ix pjid %~
decTimMvVel :: Prop -> World -> World
decTimMvVel pj = props . ix pjid %~
( (pjTimer -~ 1)
. (pjPos %~ (+.+ vel) )
. (pjAcc %~ rotateV rot )
src/Dodge/Item/Weapon/UseEffect.hs
+7 -7
View File
@@ -113,19 +113,19 @@ aTractorBeam
aTractorBeam col cr w
= set (creatures . ix cid . crInv . ix itRef . itUse)
(\_ -> aTractorBeam ((col + 1) `mod` 10))
$ over projectiles (IM.insert i (tractorBeamAt col i pos dir)) w
$ over props (IM.insert i (tractorBeamAt col i pos dir)) w
where
i = newProjectileKey w
cid = _crID cr
pos = _crPos cr +.+ ((_crRad cr + 10) *.* unitVectorAtAngle dir)
dir = _crDir cr
itRef = _crInvSel cr
tractorBeamAt :: Int -> Int -> Point2 -> Float -> Projectile
tractorBeamAt :: Int -> Int -> Point2 -> Float -> Prop
tractorBeamAt colID i pos dir = Projectile
{ _pjPos = pos
, _pjStartPos = p'
, _pjVel = d
, _pjDraw = const blank
, _prDraw = const (mempty,blank)
, _pjID = i
, _pjUpdate = \_ -> updateTractor colID 10 i
}
@@ -137,12 +137,12 @@ tractorBeamAt colID i pos dir = Projectile
The interaction of this with objects, walls etc needs more thought. -}
updateTractor :: Int -> Int -> Int -> World -> World
updateTractor colID time i w
| time > 0 = set (projectiles . ix i . pjUpdate) (\_ -> updateTractor colID (time-1) i)
$ set (projectiles . ix i . pjDraw) (const pic)
| time > 0 = set (props . ix i . pjUpdate) (\_ -> updateTractor colID (time-1) i)
$ set (props . ix i . prDraw) (const (mempty,mempty))
$ over creatures (IM.map tractCr)
$ over floorItems (IM.map tractFlIt)
w
| otherwise = over projectiles (IM.delete i) w
| otherwise = over props (IM.delete i) w
where
tractCr cr
| circOnSeg p1 p2 cP 10
@@ -166,7 +166,7 @@ updateTractor colID time i w
iP = _flItPos it
m | dist iP p1 < 350 = 1
| otherwise = (410 - dist iP p1) / 60
pj = _projectiles w IM.! i
pj = _props w IM.! i
q = _pjVel pj
p1 = _pjPos pj
p' = _pjStartPos pj
src/Dodge/LevelGen/Block.hs
+6 -6
View File
@@ -24,10 +24,10 @@ import System.Random
updateBlocks :: World -> World
updateBlocks w
= (\w' -> seq (_wallsZone w') w')
$ flip (foldr removeFromZone) deadPanes
$ flip (foldl' $ flip removeFromZone) deadPanes
$ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls) degradeBlocks
where
degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks
degradeBlocks = deadBlocks `seq` foldl' (flip killBlock) w deadBlocks
removeFromZone :: Wall -> World -> World
removeFromZone bl = over (wallsZone . znObjects . ix x . ix y) (IM.delete (_wlID bl))
where
@@ -40,7 +40,7 @@ updateBlocks w
{- | Destroy a block.
Plays destruction sound and sets to be displayed other walls that were shadowed by this wall. -}
killBlock :: Wall -> World -> World
killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ w
killBlock bl w = f bl . flip (foldl' $ flip unshadow) (_blShadows bl) $ w
where
f :: Wall -> World -> World
f bl'
@@ -84,7 +84,7 @@ pushPointTowardsBy
pushPointTowardsBy x p ps = do
xs <- replicateM (length ps) $ state $ randomR (0, x / fromIntegral (length ps))
let toAdd p' y = y *.* (p' -.- p)
return $ p +.+ foldr1 (+.+) (zipWith toAdd ps xs)
return $ p +.+ foldl1' (+.+) (zipWith toAdd ps xs)
shrinkPolygon
:: RandomGen g
@@ -105,7 +105,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w
| hp <= 0 && null degradability = w
| hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
| otherwise = w
& wallsZone . znObjects %~ flip (IM.foldr wallInZone) panes
& wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
& walls %~ IM.union panes
where
lns = zip (p:ps) (ps ++ [p])
@@ -128,7 +128,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w
wallInZone wl
| uncurry dist (_wlLine wl) <= 2*zoneSize
= insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
| otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl)) ips
where
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
wlid = _wlID wl
src/Dodge/Render.hs
+33 -28
View File
@@ -42,16 +42,24 @@ doDrawing pdata w = do
viewFroms@(V2 vfx vfy) = _cameraViewFrom w
viewFrom3d = Vector3 vfx vfy 20
shadV = _pictureShaders pdata
lwShad = _lightingWallShadShader pdata
-- bind as much data into vbos as feasible at this point
-- pictures setup
layerCounts <- UMV.replicate (6*6) 0
shapeCounts <- UMV.replicate 3 (0 :: Int)
-- attempt to do this poking in parallel
nWalls <- MP.bindM3 (\ _ a _ -> return a)
-- pictures poking
-- count mutable vectors setup
layerCounts <- UMV.replicate (6*6) 0
shapeCounts <- UMV.replicate 3 (0 :: Int)
wlwiflCounts <- UMV.replicate 3 (0 :: Int)
-- attempt to poke in parallel
MP.bindM3 (\ _ _ _ -> return ())
( pokeBindFoldableLayer shadV layerCounts $ worldPictures w )
-- poke wall points and colors
( poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol )
( pokeWallsWindowsFloor
(shadVBOptr $ _wallTextureShader pdata)
(shadVBOptr $ _windowShader pdata)
(shadVBOptr $ _textureArrayShader pdata)
wlwiflCounts
wallPointsCol
windowPoints
(_floorTiles w)
)
( pokeShape
(_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
(_eboPtr $ _shapeEBO pdata)
@@ -62,10 +70,15 @@ doDrawing pdata w = do
nShapeVs <- UMV.read shapeCounts 0
nIndices <- UMV.read shapeCounts 1
nSilIndices <- UMV.read shapeCounts 2
nWalls <- UMV.read wlwiflCounts 0
nWins <- UMV.read wlwiflCounts 1
nFls <- UMV.read wlwiflCounts 2
-- bind wall points, silhouette data, surface geometry
uncurry bindShaderBuffers $ unzip
[ ( _wallTextureShader pdata, nWalls)
, (_shapeShader pdata, nShapeVs)
, (_windowShader pdata, nWins)
, (_textureArrayShader pdata, nFls)
]
bindBuffer ElementArrayBuffer $= Just (_ebo $ _shapeEBO pdata)
bufferSubData
@@ -89,9 +102,13 @@ doDrawing pdata w = do
clear [ColorBuffer,DepthBuffer]
depthFunc $= Just Less
-- draw wall occlusions from the camera's point of view
currentProgram $= Just (_shadProg $ _lightingOccludeShader pdata)
uniform (head $ _shadUnis $ _lightingOccludeShader pdata) $= viewFrom3d
drawShader (_lightingOccludeShader pdata) nWalls
currentProgram $= Just (_shadProg lwShad)
uniform (head $ _shadUnis lwShad) $= viewFrom3d
bindVertexArrayObject $= Just (_vao $ _shadVAO lwShad)
glDrawArrays
(marshalEPrimitiveMode $ _shadPrim lwShad)
0
(fromIntegral nWalls)
--draw walls onto base buffer
if w ^. config . wall_textured
then renderTextureWalls pdata nWalls
@@ -108,9 +125,8 @@ doDrawing pdata w = do
GL_UNSIGNED_SHORT
nullPtr
--draw floor onto base buffer
nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w)
bindShaderBuffers [_textureArrayShader pdata] [nTextArrayVs]
drawShader (_textureArrayShader pdata) nTextArrayVs
-- nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w)
drawShader (_textureArrayShader pdata) nFls
--draw lightmap into its own buffer
bindFramebuffer Framebuffer $= fst (_fboLighting pdata)
createLightMap pdata lightPoints nWalls nSilIndices nIndices (snd $ snd $ _fboBase pdata)
@@ -154,14 +170,15 @@ doDrawing pdata w = do
drawBuffers $= [FBOColorAttachment 0,NoBuffers]
clear [ColorBuffer]
renderLayer 2 shadV layerCounts
renderWindows pdata windowPoints
--renderWindows pdata windowPoints
drawShader (_windowShader pdata) nWins
when (_cloud_shadows $ _config w) $ do
----render transparency depths
depthMask $= Enabled
blend $= Disabled
drawBuffers $= [NoBuffers,FBOColorAttachment 1]
renderLayer 2 shadV layerCounts
renderWindows pdata windowPoints
drawShader (_windowShader pdata) nWins
----draw lightmap for cloud buffer
depthMask $= Disabled
blend $= Enabled
@@ -247,18 +264,6 @@ renderBlankWalls pdata nWalls = do
drawShader (_wallBlankShader pdata) nWalls
cullFace $= Nothing
renderWindows
:: RenderData
-> [((Point2,Point2),Point4)] -- ^ List: wall positions and color
-> IO ()
renderWindows pdata wps = do
n <- poke224s (shadVBOptr $ _windowShader pdata) wps
bindShaderBuffers [_windowShader pdata] [n]
currentProgram $= Just (_shadProg $ _windowShader pdata)
--cullFace $= Just Back
drawShader (_windowShader pdata) n
--cullFace $= Nothing
renderTextureWalls
:: RenderData
-> Int -- ^ number of walls
src/Dodge/Render/Picture.hs
+1 -1
View File
@@ -27,7 +27,7 @@ import qualified Data.Map as M
worldPictures :: World -> Picture
worldPictures w = pictures
[pictures (_decorations w)
,concatMapPic (dbArg _pjDraw) $ _projectiles w
,concatMapPic (_spPicture . dbArg _prDraw) $ _props w
,concatMapPic (crDraw w) . IM.filter crIsClose $ _creatures w
,concatMapPic (dbArg _ptDraw) $ _particles w
,testPic w
src/Dodge/Render/Shape.hs
+4 -2
View File
@@ -1,6 +1,7 @@
module Dodge.Render.Shape
where
import Dodge.Data
import Dodge.Base
import Shape
import Geometry
--import Color
@@ -11,8 +12,9 @@ import Dodge.Render.ShapePicture
import qualified Data.IntMap as IM
worldShape :: World -> Shape
worldShape w = _foregroundShape w
<> mconcat (map (crShape w) (IM.elems $ IM.filter (pointIsClose . _crPos) (_creatures w)))
<> mconcat (map (_spShape . floorItemSPic) $ IM.elems $ IM.filter (pointIsClose . _flItPos) $ _floorItems w)
<> foldMap (crShape w) (IM.elems $ IM.filter (pointIsClose . _crPos) (_creatures w))
<> (foldMap (_spShape . floorItemSPic) $ IM.elems $ IM.filter (pointIsClose . _flItPos) $ _floorItems w)
<> foldMap (_spShape . dbArg _prDraw) (IM.filter (pointIsClose . _pjPos) $ _props w)
where
pointIsClose p = dist camCen p < winSize
winSize = 30 + max (getWindowX w) (getWindowY w)
src/Dodge/Update.hs
+6 -6
View File
@@ -118,12 +118,12 @@ updateTriggers w
cr = _creatures w IM.! 0 & crPos .~ V2 0 0
updateLightSources :: World -> World
updateLightSources w = set tempLightSources tlss w
updateLightSources w = over tempLightSources f w
where
tlss = mapMaybe (\b -> _tlsUpdate b w b) $ _tempLightSources w
f = mapMaybe (\b -> _tlsUpdate b w b)
updateProjectiles :: World -> World
updateProjectiles w = IM.foldl' (flip $ dbArg _pjUpdate) w $ _projectiles w
updateProjectiles w = IM.foldl' (flip $ dbArg _pjUpdate) w $ _props w
{-
Apply internal particle updates, delete 'Nothing's. -}
updateParticles :: World -> World
@@ -151,7 +151,7 @@ ppEvents :: World -> World
ppEvents w = IM.foldl' (flip $ \pp w' -> _ppEvent pp pp w') w $ _pressPlates w
updateSeenWalls :: World -> World
updateSeenWalls w = foldr markSeen w wallsToUpdate
updateSeenWalls w = foldl' (flip markSeen) w wallsToUpdate
where
vPos = _cameraViewFrom w
wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
@@ -224,10 +224,10 @@ clClSpringVel a v b
radDist = (_clRad a + _clRad b) / 2
simpleCrSprings :: World -> World
simpleCrSprings w = IM.foldr crSpring w $ _creatures w
simpleCrSprings w = IM.foldl' (flip crSpring) w $ _creatures w
crSpring :: Creature -> World -> World
crSpring c w = IM.foldr (crCrSpring c) w cs
crSpring c w = IM.foldl' (flip $ crCrSpring c) w cs
where
cs = creaturesNearPoint (_crPos c) w
src/Dodge/WallCreatureCollisions.hs
+6 -4
View File
@@ -3,8 +3,8 @@ module Dodge.WallCreatureCollisions
( colCrsWalls
) where
import Dodge.Data
import Dodge.Data.DamageType
import Dodge.Creature.State.Data
--import Dodge.Data.DamageType
--import Dodge.Creature.State.Data
import Dodge.Zone
import Dodge.Base
import Dodge.Config.Data
@@ -50,8 +50,10 @@ pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall
pushOrCrush :: [(Point2,Point2)] -> Creature -> Creature
pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
[] -> cr
[p] -> cr & crPos .~ p
_ -> cr & crState . crDamage %~ ( Blunt 50 cpos cpos cpos : )
(p:_) -> cr & crPos .~ p
-- (_:p:_) -> cr
-- & crPos .~ p
-- & crState . crDamage %~ ( Blunt 50 cpos cpos cpos : )
where
cpos = _crPos cr
src/Preload/Render.hs
+3 -3
View File
@@ -116,7 +116,7 @@ preloadRender = do
let silEBO = EBO {_ebo = silEBOname, _eboPtr = silEBOptr}
shEdgeVAO = VAO { _vao = shEdgeVAOname, _vaoVBO = shVBO }
-- lighting shaders
lightingOccludeShad <- makeShaderUsingVAO "lighting/occlude" [vert,geom,frag] EPoints wpVAO
lightingWallShadShad <- makeShaderUsingVAO "lighting/wallShadow" [vert,geom,frag] EPoints wpVAO
>>= addUniforms ["lightPos"]
lightingCapShad
<- makeShaderUsingVAO "lighting/cap" [vert,geom,frag] ETriangles shPosVAO
@@ -201,7 +201,7 @@ preloadRender = do
, _silhouetteEBO = silEBO
, _lightingCapShader = lightingCapShad
, _lightingLineShadowShader = lightingLineShadowShad
, _lightingOccludeShader = lightingOccludeShad
, _lightingWallShadShader = lightingWallShadShad
, _wallBlankShader = wallBlankShad
, _wallTextureShader = wallTextureShad
, _windowShader = wallBlankShad { _shadVAO = winColVAO }
@@ -239,6 +239,6 @@ cleanUpRenderPreload :: RenderData -> IO ()
cleanUpRenderPreload pd = do
-- TODO fix this
--mapM_ freeShaderPointers $ _pictureShaders pd
freeShaderPointers $ _lightingOccludeShader pd
freeShaderPointers $ _lightingWallShadShader pd
freeShaderPointers $ _fullscreenShader pd
src/Render.hs
+18 -7
View File
@@ -38,6 +38,8 @@ createLightMap
createLightMap pdata lightPoints nWalls nSils nCaps toPos = do
let llsShad = _lightingLineShadowShader pdata
let lcShad = _lightingCapShader pdata
let lwShad = _lightingWallShadShader pdata
let flShad = _fullLightingShader pdata
-- we assume that the renderbuffer's depth has been correctly set elsewhere
-- we will not be changing that here
depthMask $= Disabled
@@ -59,10 +61,15 @@ createLightMap pdata lightPoints nWalls nSils nCaps toPos = do
stencilOpSeparate Back $= (OpKeep,OpKeep,OpDecrWrap)
stencilFunc $= (Always, 0, 255)
--draw wall shadows
currentProgram $= Just (_shadProg $ _lightingOccludeShader pdata)
uniform (head $ _shadUnis $ _lightingOccludeShader pdata)
currentProgram $= Just (_shadProg lwShad)
uniform (head $ _shadUnis lwShad)
$= Vector3 x y z
drawShader (_lightingOccludeShader pdata) nWalls
bindVertexArrayObject $= Just (_vao $ _shadVAO lwShad)
glDrawArrays
(marshalEPrimitiveMode $ _shadPrim lwShad)
0
(fromIntegral nWalls)
--drawShader lwShad nWalls
--draw silhouette shadows
currentProgram $= Just (_shadProg llsShad)
uniform (head $ _shadUnis $ _lightingLineShadowShader pdata)
@@ -91,12 +98,16 @@ createLightMap pdata lightPoints nWalls nSils nCaps toPos = do
colorMask $= Color4 Enabled Enabled Enabled Enabled
stencilOp $= (OpKeep,OpKeep,OpKeep)
stencilFunc $= (Equal, 0, 255)
currentProgram $= Just (_shadProg $ _fullLightingShader pdata)
uniform (head $ _shadUnis $ _fullLightingShader pdata)
currentProgram $= Just (_shadProg flShad)
uniform (head $ _shadUnis flShad)
$= Vector3 x y z
uniform (_shadUnis (_fullLightingShader pdata) !! 1)
uniform (_shadUnis flShad !! 1)
$= Vector4 r g b rad
drawShader (_fullLightingShader pdata) 4
bindVertexArrayObject $= Just (_vao $ _shadVAO flShad)
glDrawArrays
(marshalEPrimitiveMode (_shadPrim flShad))
0
(fromIntegral (4::Int))
--cleanup: may not be necessary, depending on what comes after...
cullFace $= Nothing
stencilTest $= Disabled
src/Shader/Poke.hs
+56 -39
View File
@@ -5,9 +5,9 @@ module Shader.Poke
, pokeLayVerxs
, pokeArrayOff
, pokePoint33s
, poke224s
, pokeShape
, pokePoint3s
, pokeWallsWindowsFloor
) where
import Shader.Data
import Shader.Parameters
@@ -39,7 +39,7 @@ pokeVerxs vbos count vxs = VS.mapM_ (pokeVerx vbos count) $ VS.fromList vxs
pokeVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do
typeOff <- UMV.unsafeRead offsets sn
basePtr <- _vboPtr . _vaoVBO . _shadVAO <$> MV.read vbos sn
basePtr <- _vboPtr . _vaoVBO . _shadVAO <$> MV.unsafeRead vbos sn
let thePtr = plusPtr basePtr (typeOff * pokeStride sn * floatSize)
poke34 thePtr thePos theCol
pokeArrayOff thePtr 7 ext
@@ -47,6 +47,46 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the
where
sn = _unShadNum theShadNum
pokeWallsWindowsFloor
:: Ptr Float
-> Ptr Float
-> Ptr Float
-> UMV.MVector (PrimState IO) Int
-> [ ( (Point2,Point2) , Point4 ) ]
-> [ ( (Point2,Point2) , Point4 ) ]
-> [ ( Point3 , Point3 ) ]
-> IO ()
pokeWallsWindowsFloor wlptr wiptr flptr counts wls wis fls = do
VS.mapM_ (pokeW wlptr counts 0) (VS.fromList wls)
VS.mapM_ (pokeW wiptr counts 1) (VS.fromList wis)
VS.mapM_ (pokeF flptr counts) (VS.fromList fls)
pokeF :: Ptr Float -> UMV.MVector (PrimState IO) Int -> (Point3,Point3) -> IO ()
pokeF ptr counts (V3 a b c,V3 d e f) = do
i' <- UMV.unsafeRead counts 2
let i = i' * 6
pokeElemOff ptr (i + 0) a
pokeElemOff ptr (i + 1) b
pokeElemOff ptr (i + 2) c
pokeElemOff ptr (i + 3) d
pokeElemOff ptr (i + 4) e
pokeElemOff ptr (i + 5) f
UMV.unsafeModify counts (+1) 2
pokeW :: Ptr Float -> UMV.MVector (PrimState IO) Int -> Int -> ((Point2,Point2),Point4) -> IO ()
pokeW ptr counts iv ((V2 a b,V2 c d),V4 e f g h) = do
i' <- UMV.unsafeRead counts iv
let i = i' * 8
pokeElemOff ptr (i + 0) a
pokeElemOff ptr (i + 1) b
pokeElemOff ptr (i + 2) c
pokeElemOff ptr (i + 3) d
pokeElemOff ptr (i + 4) e
pokeElemOff ptr (i + 5) f
pokeElemOff ptr (i + 6) g
pokeElemOff ptr (i + 7) h
UMV.unsafeModify counts (+1) iv
pokeShape
:: Ptr Float
-> Ptr GLushort
@@ -64,7 +104,7 @@ pokeShapeObj
-> ShapeObj
-> IO ()
pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of
TopPrism size -> pokeTopPrism size ptr iptr ieptr counts shVerts
TopPrism size -> pokeTopPrism (size - 2) ptr iptr ieptr counts shVerts
pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort
-> Ptr GLushort
@@ -72,44 +112,37 @@ pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort
-> [ShapeV]
-> IO ()
pokeTopPrism size ptr iptr ieptr counts svs = do
-- MP.bindM3 (\a b c -> return (a,b,c))
-- (VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs) )
-- (UV.foldM (pokeTopPrismIndex nv iptr) ni (memoTopPrismIndices V.! (size - 2)) )
-- (UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2)) )
nv <- UMV.read counts 0
UV.mapM_ (pokeTopPrismIndex nv iptr counts) (memoTopPrismIndices V.! (size - 2))
UV.mapM_ (pokeTopPrismEdgeIndex nv ieptr counts) (memoTopPrismEdgeIndices V.! (size - 2))
VS.mapM_ (pokeJustV ptr counts) (VS.fromList svs)
-- UMV.modify counts (+ nv') 0
-- UMV.modify counts (+ ni') 1
-- UMV.modify counts (+ nei') 2
--return (nv',ni',nei')
nv <- UMV.unsafeRead counts 0
-- MP.bindM3 (\_ _ _ -> return ())
UV.mapM_ (pokeTopPrismIndex nv iptr counts) (memoTopPrismIndices V.! size)
UV.mapM_ (pokeTopPrismEdgeIndex nv ieptr counts) (memoTopPrismEdgeIndices V.! size)
VS.mapM_ (pokeJustV ptr counts) (VS.fromList svs)
pokeTopPrismEdgeIndex :: Int -> Ptr GLushort
-> UMV.MVector (PrimState IO) Int
-> Int
-> IO ()
pokeTopPrismEdgeIndex nv eiptr counts ioff = do
nei <- UMV.read counts 2
nei <- UMV.unsafeRead counts 2
pokeElemOff eiptr nei (fromIntegral $ nv + ioff)
UMV.modify counts (+1) 2
UMV.unsafeModify counts (+1) 2
pokeTopPrismIndex :: Int -> Ptr GLushort
-> UMV.MVector (PrimState IO) Int
-> Int
-> IO ()
pokeTopPrismIndex nv iptr counts ioff = do
ni <- UMV.read counts 1
ni <- UMV.unsafeRead counts 1
pokeElemOff iptr ni (fromIntegral $ nv + ioff)
UMV.modify counts (+1) 1
UMV.unsafeModify counts (+1) 1
memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int)
memoTopPrismEdgeIndices = V.generate 6 f
memoTopPrismEdgeIndices = V.generate 10 f
where
f n = UV.fromList $ topPrismEdgeIndices (n + 2)
memoTopPrismIndices :: V.Vector (UV.Vector Int)
memoTopPrismIndices = V.generate 6 f
memoTopPrismIndices = V.generate 10 f
where
f n = UV.fromList $ topPrismIndices (n + 2)
@@ -136,7 +169,7 @@ topPrismIndices n = concatMap f [1..n-2] -- triangles on top face
pokeJustV :: Ptr Float -> UMV.MVector (PrimState IO) Int -> ShapeV -> IO ()
pokeJustV ptr counts sh = do
nv <- UMV.read counts 0
nv <- UMV.unsafeRead counts 0
let off i = nv*7 + i
pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b
@@ -145,7 +178,7 @@ pokeJustV ptr counts sh = do
pokeElemOff ptr (off 4) e
pokeElemOff ptr (off 5) f
pokeElemOff ptr (off 6) g
UMV.modify counts (+1) 0
UMV.unsafeModify counts (+1) 0
where
V3 a b c = _svPos sh
V4 d e f g = _svCol sh
@@ -226,19 +259,3 @@ pokePoint33 ptr n (V3 a b c,V3 d e f) = do
where
off i = n*6 + i
pokePoint224 :: Ptr Float -> Int -> ((Point2,Point2),Point4) -> IO Int
pokePoint224 ptr n ((V2 a b,V2 c d),V4 e f g h) = do
pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b
pokeElemOff ptr (off 2) c
pokeElemOff ptr (off 3) d
pokeElemOff ptr (off 4) e
pokeElemOff ptr (off 5) f
pokeElemOff ptr (off 6) g
pokeElemOff ptr (off 7) h
return (n + 1)
where
off i = n*8 + i
poke224s :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int
poke224s ptr = VS.foldlM' (pokePoint224 ptr) 0 . VS.fromList
src/Shape.hs
+35
View File
@@ -4,6 +4,8 @@ module Shape
, translateSH
, emptySH
, upperPrismPoly
, upperPrismPolyHalf
, prismPoly
, polyCirc
, translateSHz
, translateSHf
@@ -25,6 +27,23 @@ polyCirc :: Int -> Float -> [Point2]
{-# INLINE polyCirc #-}
polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n*2) [0,pi/fromIntegral n..]
-- very "unsafe": be careful with the inputs
-- length of polys must be the same
-- points should be correctly ordered so that
-- polys form a prism-like object with quad faces between them
prismPoly
:: [Point3]
-> [Point3]
-> Shape
{-# INLINE prismPoly #-}
prismPoly upps downps = [ShapeObj (TopPrism n) (f upps downps)]
where
n = length upps
f (a:as) (b:bs) = g a:g b:f as bs
f [] _ = []
f _ [] = []
g p = ShapeV p black
upperPrismPoly
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
@@ -41,6 +60,22 @@ upperPrismPoly h ps = [ShapeObj (TopPrism n) (f upps downps)]
f' (V2 x y) = pairToSV (V3 x y h, black)
f'' (V2 x y) = pairToSV (V3 x y 0, black)
upperPrismPolyHalf
:: Float -- ^ height, expected to be strictly positive
-> [Point2]
-> Shape
{-# INLINE upperPrismPolyHalf #-}
upperPrismPolyHalf h ps = [ShapeObj (TopPrism n) (f upps downps)]
where
n = length ps
upps = map f' ps
downps = map f'' ps
f (a:as) (b:bs) = a:b:f as bs
f [] _ = []
f _ [] = []
f' (V2 x y) = pairToSV (V3 (0.5 * x) (0.5 * y) h, black)
f'' (V2 x y) = pairToSV (V3 x y 0, black)
colorSH :: Color -> Shape -> Shape
{-# INLINE colorSH #-}
colorSH col = overCol $ const col