diff --git a/src/Dodge/Bullet.hs b/src/Dodge/Bullet.hs index 2bba058f1..803189359 100644 --- a/src/Dodge/Bullet.hs +++ b/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 diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 7d05e86a7..c217ff52a 100644 --- a/src/Dodge/Data.hs +++ b/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 diff --git a/src/Dodge/Data/Wall.hs b/src/Dodge/Data/Wall.hs index 2c9db2f7d..ad4d1889c 100644 --- a/src/Dodge/Data/Wall.hs +++ b/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 diff --git a/src/Dodge/Default/Wall.hs b/src/Dodge/Default/Wall.hs index db85d83f4..40b66be1e 100644 --- a/src/Dodge/Default/Wall.hs +++ b/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) diff --git a/src/Dodge/Placement/Instance/Sensor.hs b/src/Dodge/Placement/Instance/Sensor.hs index 1fc662050..111064765 100644 --- a/src/Dodge/Placement/Instance/Sensor.hs +++ b/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 - & mcColor .~ yellow - & mcMounts . at ObTrigger .~ mtrid - & mcMounts . at ObLightSource ?~ lsid - & mcDraw .~ sensorSPic wdth (_sensorCoding (_genParams gw) M.! dt) - & mcSensor .~ DamageSensor False 0 dt + $ \gw -> (,) gw $ PutMachine (reverse $ square wdth) + (defaultMachine + & mcColor .~ yellow + & mcMounts . at ObTrigger .~ mtrid + & mcMounts . at ObLightSource ?~ lsid + & mcDraw .~ sensorSPic wdth (_sensorCoding (_genParams gw) M.! dt) + & mcSensor .~ DamageSensor False 0 dt + ) + defaultSensorWall lightSensor :: Float -> Maybe Int diff --git a/src/Dodge/Placement/Instance/Terminal.hs b/src/Dodge/Placement/Instance/Terminal.hs index 78ed372bd..a55e83adf 100644 --- a/src/Dodge/Placement/Instance/Terminal.hs +++ b/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 diff --git a/src/Dodge/Placement/Instance/Turret.hs b/src/Dodge/Placement/Instance/Turret.hs index c93b6be3c..d81ce0b09 100644 --- a/src/Dodge/Placement/Instance/Turret.hs +++ b/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) - { _mcDraw = drawTurret --- , _mcUpdate = updateTurret rotSpeed - , _mcType = lasTurret & tuTurnSpeed .~ rotSpeed - , _mcHP = 50000 - } +putLasTurret rotSpeed = sps0 $ PutMachine (reverse $ square wdth) + (defaultMachine + & mcColor .~ blue + & mcDraw .~ drawTurret + & mcType .~ (lasTurret & tuTurnSpeed .~ rotSpeed) + & mcHP .~ 50000 + ) + defaultMachineWall lasTurret :: MachineType lasTurret = Turret { _tuWeapon = lasGun diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index cc2786e65..d502d293f 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/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 wallpoly mc p rot gw = (mcid +plMachine :: [Point2] -> Machine -> Wall -> Point2 -> Float -> World -> (Int,World) +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 col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly +placeMachineWalls :: Wall -> Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall +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