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

Fix explosion damage

Browse Source
This commit is contained in:
justin
2022-07-11 20:26:19 +01:00
parent 1506f5a83e
commit 791d065eff
10 changed files with 87 additions and 74 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/Collide.hs
+1 -1
View File
@@ -138,7 +138,7 @@ overlapCircWalls :: Point2 -> Float -> StreamOf Wall
overlapCircWalls p r = S.mapMaybe dointersect
where
dointersect wl = f (_wlLine wl) <&> (,wl)
f (a,b) = intersectSegSeg p (p -.- r *.* vNormal (normalizeV (a -.- b))) 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
collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall
src/Dodge/Creature/HandPos.hs
+7
View File
@@ -158,6 +158,13 @@ translateToChest cr
| twists cr = rotateSP (-1)
| otherwise = id
translateToBack :: Creature -> SPic -> SPic
translateToBack cr
| 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
src/Dodge/Data.hs
+6 -1
View File
@@ -150,7 +150,7 @@ data World = World
, _toPlaySounds :: M.Map SoundOrigin Sound
, _playingSounds :: M.Map SoundOrigin Sound
, _decorations :: IM.IntMap Picture
, _shapes :: IM.IntMap ForegroundShape
, _foregroundShapes :: IM.IntMap ForegroundShape
, _corpses :: IM.IntMap Corpse
, _clickMousePos :: Point2
, _pathGraph :: Gr Point2 PathEdge
@@ -1064,6 +1064,10 @@ data MachineType
, _tuFireTime :: Int
, _tuMCrID :: Maybe Int
}
data BlockShifter = BlockShifter
{ _bsID :: Int
, _bsBlocks :: IS.IntSet
}
data Door = Door
{ _drID :: Int
, _drWallIDs :: IS.IntSet
@@ -1454,6 +1458,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutDoor Color EdgeObstacle (World -> Bool) [(Point2,Point2)]
| RandPS (State StdGen PSType)
| PutForeground ForegroundShape
| PutDecoration Picture
| PutWorldUpdate (PlacementSpot -> World -> World)
| PutNothing
| PutUsingGenParams (World -> (World,PSType))
src/Dodge/Default/World.hs
+1 -1
View File
@@ -96,7 +96,7 @@ defaultWorld = World
--, _keyConfig = defaultKeyConfigSDL
-- , _config = defaultConfig
, _sideEffects = return
, _shapes = mempty
, _foregroundShapes = mempty
, _distortions = []
, _gameRooms = []
, _roomClipping = []
src/Dodge/Item/Equipment/Shape.hs
+3 -1
View File
@@ -11,6 +11,7 @@ pictureOnEquip sp cr itm = fromMaybe mempty $ do
i <- itm ^? itPos . ipInvID
epos <- cr^? crInvEquipped . ix i
return $ equipPosition epos cr sp
equipPosition :: EquipPosition -> Creature -> SPic -> SPic
equipPosition epos cr sh = case epos of
OnLeftWrist -> translateToLeftWrist cr sh
@@ -19,4 +20,5 @@ equipPosition epos cr sh = case epos of
translateToRightLeg cr (mirrorSPxz sh)
OnHead -> translateToHead cr sh
OnChest -> translateToChest cr sh
_ -> sh
OnBack -> translateToBack cr sh
OnSpecial -> sh
src/Dodge/Placement/PlaceSpot.hs
+8 -3
View File
@@ -17,6 +17,7 @@ import Dodge.Base.NewID
import Geometry
import qualified IntMapHelp as IM
import Color
import Picture
import Data.Foldable
import Data.Maybe
@@ -91,7 +92,8 @@ placeSpotID ps pt w = case pt of
PutTerminal tm -> plNewUpID terminals tmID tm w
PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w
PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w
PutForeground fs -> plNewUpID shapes fsID (mvFS p rot fs) w
PutForeground fs -> plNewUpID foregroundShapes fsID (mvFS p rot fs) w
PutDecoration pic -> plNewID decorations (shiftDec p rot pic) w
PutMachine pps mc -> plMachine (map doShift pps) mc p rot w
PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
@@ -115,6 +117,9 @@ placeSpotID ps pt w = case pt of
rot = _psRot ps
doShift = shiftPointBy (p,rot)
shiftDec :: Point2 -> Float -> Picture -> Picture
shiftDec p r pic = uncurryV translate p $ rotate r pic
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World)
evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
where
@@ -167,10 +172,10 @@ mvFS p a = (fsDir +~ a) . (fsPos %~ ( (p +.+) . rotateV a ))
plMachine :: [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
plMachine wallpoly mc p rot gw = (mcid
, gw & machines %~ addMc
& walls %~ placeMachineWalls color wallpoly mcid wlid
& walls %~ placeMachineWalls col wallpoly mcid wlid
)
where
color = _mcColor mc
col = _mcColor mc
w' = gw
mcid = IM.newKey $ _machines w'
wlid = IM.newKey $ _walls w'
src/Dodge/Render/ShapePicture.hs
+1 -1
View File
@@ -53,7 +53,7 @@ worldSPic cfig w
= singleSPic (mempty, extraPics cfig w)
<> foldup (dbArg _prDraw) (filtOn' _prPos _props)
<> foldup (shiftDraw _blPos _blDir _blDraw) (filtOn' _blPos _blocks)
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _shapes)
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn' _fsPos _foregroundShapes)
<> foldup (dbArg _cpPict) (filtOn' _cpPos _corpses)
<> foldup drawCreature (filtOn' _crPos _creatures)
<> foldup floorItemSPic (filtOn' _flItPos _floorItems)
src/Dodge/Room/Foreground.hs
+56 -64
View File
@@ -1,11 +1,21 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Room.Foreground where
module Dodge.Room.Foreground
( thinHighBar
, putShape
, girder
, girderZ
, girderV
, girderV'
, barPP
, highDiagonalMesh
, highMesh
) where
import Dodge.Data
import Picture
import Geometry
import Shape
import Quaternion
--import Bound
import Bound
--import Dodge.Data.ForegroundShape
import Dodge.Default.Foreground
@@ -13,8 +23,16 @@ import Data.List
import Data.Maybe
import Control.Lens
import ShapePicture
--import Streaming
--import qualified Streaming.Prelude as S
import Streaming
import qualified Streaming.Prelude as S
highMesh
:: Point2
-> Point2
-> Float -- ^ width
-> Picture
highMesh pa pb w = highDiagonalMesh pa pb w 20
<> highDiagonalMesh (pa +.+ w *.* normalizeV (vNormal (pb -.- pa))) pa (dist pa pb) 20
highDiagonalMesh
:: Point2
@@ -22,10 +40,10 @@ highDiagonalMesh
-> Float -- ^ width
-> Float -- ^ vertical distance between lines
-> Picture
highDiagonalMesh pa pb w d = setDepth (-0.2) $ pictures $
map (thickLine 3 . tflat2) (diagonalLinesRect pb pa w d (3*pi/4))
highDiagonalMesh pa pb w d = setDepth 100 $ pictures $
map (thickLine 2 . tflat2) (diagonalLinesRect pb pa w d (3*pi/4))
++
map (thickLine 3 . tflat2) (diagonalLinesRect pb pc (negate h) d (pi/4))
map (thickLine 2 . tflat2) (diagonalLinesRect pb pc (negate h) d (pi/4))
where
pc = pb +.+ w *.* normalizeV (vNormal (pb -.- pa))
h = dist pa pb
@@ -54,14 +72,14 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
thinHighBar :: Float -> Point2 -> Point2 -> Shape
thinHighBar = highBar 3
thinHighBarLoop :: Float -> [Point2] -> Shape
thinHighBarLoop h = foldMap (uncurry $ thinHighBar h) . loopPairs
--thinHighBarLoop :: Float -> [Point2] -> Shape
--thinHighBarLoop h = foldMap (uncurry $ thinHighBar h) . loopPairs
thinHighBarChain :: Float -> [Point2] -> Shape
thinHighBarChain h = foldMap (uncurry $ thinHighBar h) . chainPairs
--thinHighBarChain :: Float -> [Point2] -> Shape
--thinHighBarChain h = foldMap (uncurry $ thinHighBar h) . chainPairs
thickHighBar :: Float -> Point2 -> Point2 -> Shape
thickHighBar = highBar 5
--thickHighBar :: Float -> Point2 -> Point2 -> Shape
--thickHighBar = highBar 5
highBar :: Float -> Float -> Point2 -> Point2 -> Shape
highBar thickness h x y = translateSHz h $ colorSH orange $ upperPrismPoly thickness
@@ -69,13 +87,13 @@ highBar thickness h x y = translateSHz h $ colorSH orange $ upperPrismPoly thick
where
n = 0.5 * thickness *.* normalizeV (vNormal (y -.- x))
highPipe :: Float -> Point2 -> Point2 -> Shape
highPipe h x y = colorSH orange $ prismPoly
(map (addZ (h + 5)) [x +.+ n2, y +.+ n2, y -.- n2, x -.- n2])
(map (addZ h) [x +.+ n, y +.+ n, y -.- n, x -.- n] )
where
n2 = 1.25 *.* normalizeV (vNormal (y -.- x))
n = 2.5 *.* normalizeV (vNormal (y -.- x))
--highPipe :: Float -> Point2 -> Point2 -> Shape
--highPipe h x y = colorSH orange $ prismPoly
-- (map (addZ (h + 5)) [x +.+ n2, y +.+ n2, y -.- n2, x -.- n2])
-- (map (addZ h) [x +.+ n, y +.+ n, y -.- n, x -.- n] )
-- where
-- n2 = 1.25 *.* normalizeV (vNormal (y -.- x))
-- n = 2.5 *.* normalizeV (vNormal (y -.- x))
girderZ
:: Float -- ^ height
@@ -96,43 +114,20 @@ girderZ h d w x y = colorSH red $ mconcat $
ps = divideLineExact d xb yb
qs = tail $ divideLineExact d xt yt
girderVCapL
:: Float -- ^ "cap" size
-> Float -- ^ height
-> Float -- ^ distance between cross bars
-> Float -- ^ width
-> Point2 -> Point2 -> Shape
girderVCapL csize h d w x y = thinHighBar h (x -.- n) (x +.+ n)
<> girderV h d w x y
where
n = csize *.* vNormal (normalizeV (x -.- y))
girderVCapLR
:: Float -- ^ "cap" size
-> Float -- ^ height
-> Float -- ^ distance between cross bars
-> Float -- ^ width
-> Point2 -> Point2 -> Shape
girderVCapLR csize h d w x y = thinHighBar h (x -.- n) (x +.+ n)
<> thinHighBar h (y -.- n) (y +.+ n)
<> girderV h d w x y
where
n = csize *.* vNormal (normalizeV (x -.- y))
putShape :: Shape -> PSType
putShape sh = PutForeground $ defaultForeground
& fsPos .~ m
& fsRad .~ radBounds bnds
& fsSPic .~ noPic (uncurryV translateSHf (-m) sh)
where
bnds = (0,0,0,0) -- shapeBounds sh
bnds = shapeBounds sh
m = midBounds bnds
--shapePoints :: Shape -> Stream (Of Point2) Identity ()
--shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
shapePoints :: Shape -> Stream (Of Point2) Identity ()
shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
--shapeBounds :: Shape -> (Float,Float,Float,Float)
--shapeBounds = fromMaybe (0,0,0,0) . boundPoints . shapePoints
shapeBounds :: Shape -> (Float,Float,Float,Float)
shapeBounds = fromMaybe (0,0,0,0) . boundPoints . shapePoints
midBounds :: (Float,Float,Float,Float) -> Point2
midBounds (n,s,e,w) = V2 ((n + s)/2) ((e + w)/2)
@@ -200,9 +195,6 @@ girder h d w x y = mconcat $
ps = divideLineExact d xb yb
qs = divideLineExact d xt yt
robotArm :: Shape
robotArm = undefined
barPP :: Float -> Point3 -> Point3 -> Shape
barPP w a b
| a == b = mempty
@@ -212,17 +204,17 @@ barPP w a b
where
z1 = b -.-.- a
pipePP :: Float -> Point3 -> Point3 -> Shape
pipePP w a b = prismPoly
(map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
(map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
where
z1 = b -.-.- a
--pipePP :: Float -> Point3 -> Point3 -> Shape
--pipePP w a b = prismPoly
-- (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
-- (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
-- where
-- z1 = b -.-.- a
tankTopPipe :: Shape
tankTopPipe = colorSH orange $
upperPrismPoly 31 (polyCirc 4 20)
<> prismPoly
(map (addZ 41) $ polyCirc 4 5)
(map (addZ 31) $ polyCirc 4 20)
-- <> pipePP 5 (V3 0 0 51) (V3 0 0 41)
--tankTopPipe :: Shape
--tankTopPipe = colorSH orange $
-- upperPrismPoly 31 (polyCirc 4 20)
-- <> prismPoly
-- (map (addZ 41) $ polyCirc 4 5)
-- (map (addZ 31) $ polyCirc 4 20)
---- <> pipePP 5 (V3 0 0 51) (V3 0 0 41)
src/Dodge/Room/Room.hs
+2
View File
@@ -17,6 +17,7 @@ import Dodge.RoomLink
import Dodge.Default.Room
import Dodge.Creature
import Dodge.Room.Pillar
import Dodge.Room.Foreground
import Dodge.Room.Girder
import Dodge.Room.Modify.Girder
import Dodge.LevelGen.Data
@@ -47,6 +48,7 @@ roomC w h = do
. setOutLinks (\rl -> OnEdge West `S.member` _rlType rl)
)
& rmPmnts .:~ wallf (V2 (w/2) 0) (V2 (w/2) (h-60))
& rmPmnts .:~ sps0 (PutDecoration (highMesh (V2 0 0) (V2 0 h) 50))
& rmRandPSs .~ [farside]
)
where
src/Dodge/WorldEvent/Shockwave.hs
+2 -2
View File
@@ -26,8 +26,8 @@ makeShockwaveAt
-> World -- ^ Start world.
-> World
makeShockwaveAt is p rad dam push col = instantParticles .:~ Shockwave
{ _ptUpdate = mvShockwave is
, _ptColor = col
{ _ptUpdate = mvShockwave is
, _ptColor = col
, _ptPos = p
, _ptRad = rad
, _ptDam = dam