Tweak bullet bouncing and spawning

src/Dodge/Bullet.hs

@@ -17,7 +17,6 @@ import qualified Streaming.Prelude as S
 import Data.Maybe
 import Dodge.Movement.Turn
 import Dodge.WorldEvent.ThingsHit
-import Control.Monad.State
 
 updateBullet :: World -> Bullet -> (World,Maybe Bullet)
 updateBullet w bu = case _buState bu of
@@ -53,22 +52,12 @@ useAmmoParams it cr w = w & instantBullets .:~ (_amBullet bultype
 mvBullet :: Float -> World -> Bullet -> (World, Maybe Bullet)
 mvBullet x w bt' 
     | t <= 0 || magV (_buVel bt) < 1 = (endspawn w,Nothing)
-    | otherwise = bimap maybebounce (fmap dodrag) $ 
+    | otherwise = bimap id (fmap dodrag) $ 
         hiteff bt hitstream w
   where
     endspawn w' = fromMaybe w' $ do
         partspawn <- bulletSpawn bt'
         return $ partspawn p w'
-    maybebounce = fromMaybe id $ do
-        guard (_buEffect bt' == BounceBullet)
-        (hp,crwl) <- runIdentity (S.head_ hitstream)
-        dir <- bounceDir (hp,crwl)
-        return $ instantBullets .:~ (bt
-            & buPos .~ hp +.+ normalizeV (_buPos bt' -.- hp)
-            & buVel %~ reflectIn dir
-            & buTrajectory .~ BasicBulletTrajectory
-            & buTimer -~ 1
-            )
     hitstream = thingsHit p (p +.+ vel) w
     bt = foldr (\mg b -> _mgField mg mg b) bt' (_magnets w)
         & buState .~ NormalBulletState
@@ -86,7 +75,7 @@ mvBullet x w bt'
     t       = _buTimer bt
 
 bounceDir :: (Point2, Either Creature Wall) -> Maybe Point2
-bounceDir (_,Right wl) = Just $ uncurry (-.-) (_wlLine wl)
+bounceDir (_,Right wl) | _wlBouncy wl = Just $ uncurry (-.-) (_wlLine wl)
 bounceDir (p,Left  cr) | crIsArmouredFrom p cr = Just $ vNormal $ p -.- _crPos cr
 bounceDir _ = Nothing
 
@@ -101,11 +90,23 @@ hitEffFromBul :: Float -> Bullet
     -> Stream (Of (Point2, Either Creature Wall)) Identity ()
     -> World 
     -> (World,Maybe Bullet)
-hitEffFromBul x = expireAndDamage' x setfromtodams
+hitEffFromBul x bu hitstream w = case _buEffect bu of
+    PenetrateBullet -> undefined
+    BounceBullet  -> case runIdentity (S.head_ hitstream) of
+        Nothing -> (w, moveBullet x bu)
+        Just (hp,crwl) -> fromMaybe (expireAndDamage' x setfromtodams bu hitstream w) $ do
+            dir <- bounceDir (hp,crwl)
+            return $ (w,Just $ bu
+                & buPos .~ hp +.+ normalizeV (_buPos bu -.- hp)
+                & buVel %~ reflectIn dir
+                & buTrajectory .~ BasicBulletTrajectory
+                & buTimer -~ 1
+                )
+    DestroyBullet -> expireAndDamage' x setfromtodams bu hitstream w
   where
-    setfromtodams bu p = map f (_buDamages bu)
+    setfromtodams bu' p = map f (_buDamages bu')
       where
-        f = (dmFrom .~ _buPos bu) . (dmAt .~ p) . (dmTo .~ _buPos bu +.+ _buVel bu)
+        f = (dmFrom .~ _buPos bu') . (dmAt .~ p) . (dmTo .~ _buPos bu' +.+ _buVel bu')
 
 expireAndDamage' :: Float -> (Bullet -> Point2 -> [Damage])
     -> Bullet

src/Dodge/Data.hs

@@ -1207,7 +1207,7 @@ data TerminalCommand = TerminalCommand
 
 ---- ROOM DATATYPES
 data PSType = PutCrit {_unPutCrit :: Creature}
-    | PutMachine { _putMachinePoly :: [Point2], _unPutMachine :: Machine }
+    | PutMachine { _putMachinePoly :: [Point2], _putMachineMachine :: Machine , _putMachineWall :: Wall}
     | PutLS LightSource
     | PutButton {_putButton :: Button}
     | PutProp Prop

src/Dodge/Data/Wall.hs

@@ -16,6 +16,7 @@ data Wall = Wall
     , _wlOpacity        :: Opacity
     , _wlPathable       :: Bool
     , _wlPenetrable     :: Bool
+    , _wlBouncy         :: Bool
     , _wlWalkable       :: Bool
     , _wlTouchThrough   :: Bool
     , _wlFireThrough    :: Bool

src/Dodge/Default/Wall.hs

@@ -4,6 +4,8 @@ import Dodge.Data
 import Dodge.Block.Debris -- this dependency is (directly) for dirtColor
 import Picture
 import Geometry.Data
+
+import Control.Lens
 {- Indestructible wall.  -}
 defaultWall :: Wall
 defaultWall = Wall 
@@ -23,6 +25,7 @@ defaultWall = Wall
     , _wlWalkable = False
     , _wlHeight = 100
     , _wlMaterial = Stone
+    , _wlBouncy = True
     }
 defaultDoorWall' :: Wall
 defaultDoorWall' = defaultWall
@@ -44,6 +47,8 @@ defaultMachineWall = defaultWall
     , _wlMaterial  = Metal
     , _wlPenetrable = True
     }
+defaultSensorWall :: Wall
+defaultSensorWall = defaultMachineWall & wlBouncy .~ False
 defaultDirtWall :: Wall
 defaultDirtWall = defaultWall
     { _wlLine = (V2 0 0,V2 50 0)

src/Dodge/Placement/Instance/Sensor.hs

@@ -23,12 +23,15 @@ damageSensor
     -> Placement
 damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1)
     $ \lsid -> Just $ spNoID ps $ PutUsingGenParams 
-    $ \gw -> (,) gw $ PutMachine (reverse $ square wdth) $ defaultMachine 
+    $ \gw -> (,) gw $ PutMachine (reverse $ square wdth) 
-        & mcColor .~ yellow
+        (defaultMachine
-        & mcMounts . at ObTrigger .~ mtrid
+            & mcColor .~ yellow
-        & mcMounts . at ObLightSource ?~ lsid
+            & mcMounts . at ObTrigger .~ mtrid
-        & mcDraw .~ sensorSPic wdth (_sensorCoding (_genParams gw) M.! dt)
+            & mcMounts . at ObLightSource ?~ lsid
-        & mcSensor .~ DamageSensor False 0 dt
+            & mcDraw .~ sensorSPic wdth (_sensorCoding (_genParams gw) M.! dt)
+            & mcSensor .~ DamageSensor False 0 dt
+        )
+        defaultSensorWall
 
 lightSensor :: Float
     -> Maybe Int

src/Dodge/Placement/Instance/Terminal.hs

@@ -30,6 +30,7 @@ putTerminal mc tm
         (PutMachine (reverse $ square 10)
             (mc & mcMounts . at ObButton ?~ fromJust (_plMID btpl)
                 & mcCloseSound ?~ fridgeHumS)       
+            defaultSensorWall
         )
     $ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl) 
   where

src/Dodge/Placement/Instance/Turret.hs

@@ -26,12 +26,14 @@ import Data.List
 import Data.Maybe
 
 putLasTurret :: Float -> Placement
-putLasTurret rotSpeed = sps0 $ PutMachine (reverse $ square wdth) (defaultMachine & mcColor .~ blue)
+putLasTurret rotSpeed = sps0 $ PutMachine (reverse $ square wdth) 
-    { _mcDraw = drawTurret
+    (defaultMachine 
---    , _mcUpdate = updateTurret rotSpeed
+        & mcColor .~ blue
-    , _mcType = lasTurret & tuTurnSpeed .~ rotSpeed
+        & mcDraw .~ drawTurret
-    , _mcHP = 50000
+        & mcType .~ (lasTurret & tuTurnSpeed .~ rotSpeed)
-    }
+        & mcHP .~ 50000
+    )
+    defaultMachineWall
 lasTurret :: MachineType
 lasTurret = Turret
     { _tuWeapon = lasGun

src/Dodge/Placement/PlaceSpot.hs

@@ -11,7 +11,6 @@ import Dodge.Data
 import Dodge.Placement.PlaceSpot.Block
 import Dodge.Placement.PlaceSpot.TriggerDoor
 import Dodge.Path
-import Dodge.Default.Wall
 import Dodge.ShiftPoint
 import Dodge.Base.NewID
 import Geometry
@@ -94,7 +93,7 @@ placeSpotID ps pt w = case pt of
     PutCrit     cr          -> plNewUpID creatures crID (mvCr p rot cr) 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
+    PutMachine  pps mc wl   -> plMachine (map doShift pps) mc wl p rot w
     PutLS       ls          -> plNewUpID lightSources lsID (mvLS p' rot ls) w
     PutPPlate   pp          -> plNewUpID pressPlates ppID (mvPP p rot pp) w
     RandPS      rgn         -> evaluateRandPS rgn ps w
@@ -169,10 +168,10 @@ mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
 mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
 mvFS p a = (fsDir +~ a) . (fsPos %~ ( (p +.+) . rotateV a ))
 
-plMachine :: [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
+plMachine :: [Point2] -> Machine -> Wall -> Point2 -> Float -> World -> (Int,World)
-plMachine wallpoly mc p rot gw = (mcid
+plMachine wallpoly mc wl p rot gw = (mcid
     , gw & machines  %~ addMc
-         & walls     %~ placeMachineWalls col wallpoly mcid wlid
+         & walls     %~ placeMachineWalls wl col wallpoly mcid wlid
     )
   where 
     col = _mcColor mc
@@ -184,11 +183,11 @@ plMachine wallpoly mc p rot gw = (mcid
     addMc = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids})
 
 -- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
-placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
+placeMachineWalls :: Wall -> Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
-placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly
+placeMachineWalls wl col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly
   where
     f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
-    baseWall = defaultMachineWall 
+    baseWall = wl 
         & wlColor .~ col
         & wlStructure . wsMachine .~ mcid
         & wlTouchThrough .~ True