Fix explosion damage

src/Dodge/Base/Collide.hs

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 Streaming
---import qualified Streaming.Prelude as S
+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 $
+highDiagonalMesh pa pb w d = setDepth 100 $ pictures $
-    map (thickLine 3 . tflat2) (diagonalLinesRect pb pa w d (3*pi/4))
+    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 :: Float -> [Point2] -> Shape
-thinHighBarLoop h = foldMap (uncurry $ thinHighBar h) . loopPairs
+--thinHighBarLoop h = foldMap (uncurry $ thinHighBar h) . loopPairs
 
-thinHighBarChain :: Float -> [Point2] -> Shape
+--thinHighBarChain :: Float -> [Point2] -> Shape
-thinHighBarChain h = foldMap (uncurry $ thinHighBar h) . chainPairs
+--thinHighBarChain h = foldMap (uncurry $ thinHighBar h) . chainPairs
 
-thickHighBar :: Float -> Point2 -> Point2 -> Shape
+--thickHighBar :: Float -> Point2 -> Point2 -> Shape
-thickHighBar = highBar 5
+--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 :: Float -> Point2 -> Point2 -> Shape
-highPipe h x y = colorSH orange $ prismPoly
+--highPipe h x y = colorSH orange $ prismPoly
-    (map (addZ (h + 5)) [x +.+ n2, y +.+ n2, y -.- n2, x -.- n2])
+--    (map (addZ (h + 5)) [x +.+ n2, y +.+ n2, y -.- n2, x -.- n2])
-    (map (addZ h)       [x +.+ n, y +.+ n, y -.- n, x -.- n]    )
+--    (map (addZ h)       [x +.+ n, y +.+ n, y -.- n, x -.- n]    )
-  where
+--  where
-    n2 = 1.25 *.* normalizeV (vNormal (y -.- x))
+--    n2 = 1.25 *.* normalizeV (vNormal (y -.- x))
-    n = 2.5 *.* 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 :: Shape -> Stream (Of Point2) Identity ()
---shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
+shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
 
---shapeBounds :: Shape -> (Float,Float,Float,Float)
+shapeBounds :: Shape -> (Float,Float,Float,Float)
---shapeBounds = fromMaybe (0,0,0,0) . boundPoints . shapePoints
+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 :: Float -> Point3 -> Point3 -> Shape
-pipePP w a b = prismPoly
+--pipePP w a b = prismPoly
-    (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
+--    (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
-    (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
+--    (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 4 w)
-  where
+--  where
-    z1 = b -.-.- a
+--    z1 = b -.-.- a
     
-tankTopPipe :: Shape
+--tankTopPipe :: Shape
-tankTopPipe = colorSH orange $ 
+--tankTopPipe = colorSH orange $ 
-    upperPrismPoly 31 (polyCirc 4 20)
+--    upperPrismPoly 31 (polyCirc 4 20)
-    <> prismPoly 
+--    <> prismPoly 
-        (map (addZ 41) $ polyCirc 4 5)
+--        (map (addZ 41) $ polyCirc 4 5)
-        (map (addZ 31) $ polyCirc 4 20)
+--        (map (addZ 31) $ polyCirc 4 20)
---    <> pipePP 5 (V3 0 0 51) (V3 0 0 41)
+----    <> pipePP 5 (V3 0 0 51) (V3 0 0 41)

src/Dodge/Room/Room.hs

@@ -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