From 86fdfd260e8df534164de17184de2fa8d596d10d Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 31 Oct 2021 22:55:02 +0000 Subject: [PATCH] Add objects based on walls, called machines --- src/Dodge/Base/Collide.hs | 23 ++++++------ src/Dodge/Data.hs | 42 ++++++++++++++++----- src/Dodge/Data/DamageType.hs | 1 + src/Dodge/Debug/Picture.hs | 8 ++-- src/Dodge/Default.hs | 13 +++++++ src/Dodge/Default/Wall.hs | 22 ++++++----- src/Dodge/Default/World.hs | 1 + src/Dodge/Item/Weapon/BatteryGuns.hs | 2 +- src/Dodge/Item/Weapon/BulletGuns.hs | 2 +- src/Dodge/LevelGen.hs | 55 +++++++++++++++++++--------- src/Dodge/LevelGen/Block.hs | 26 ++++++------- src/Dodge/LevelGen/Data.hs | 1 + src/Dodge/LevelGen/TriggerDoor.hs | 8 ++-- src/Dodge/Machine/Sensor.hs | 21 +++++++++++ src/Dodge/Render/Picture.hs | 6 +-- src/Dodge/Render/Shape.hs | 4 ++ src/Dodge/Room/Placement.hs | 6 ++- src/Dodge/Room/Start.hs | 2 + src/Dodge/Update.hs | 7 ++-- src/Dodge/WorldEvent/DamageBlock.hs | 6 +-- src/Dodge/WorldEvent/HitEffect.hs | 3 +- src/Geometry.hs | 8 ++-- src/Geometry/Intersect.hs | 6 +-- 23 files changed, 183 insertions(+), 90 deletions(-) create mode 100644 src/Dodge/Machine/Sensor.hs diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 1c0c1b24a..9c9f13099 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -83,20 +83,23 @@ collideDirectionIndirect d p1 p2 wls = fromMaybe d $ ( L.fold - . L.prefilter (not . _wlIsSeeThrough) + . L.prefilter wlIsOpaque . L.premapMaybe (fmap (dist p1) . uncurry (intersectSegSeg p1 p3) . _wlLine) ) L.minimum wls where p3 = p1 +.+ d *.* safeNormalizeV (p2 -.- p1) +wlIsOpaque :: Wall -> Bool +wlIsOpaque wl = _wlOpacity wl == Opaque + collidePointUpToIndirect :: Point2 -- ^start point -> Point2 -- ^end point -> IM.IntMap Wall -> Point2 {-# INLINE collidePointUpToIndirect #-} -collidePointUpToIndirect p1 p2 = foldr f p2 . IM.filter (not . _wlIsSeeThrough) +collidePointUpToIndirect p1 p2 = foldr f p2 . IM.filter wlIsOpaque where f wl x = fromMaybe x . uncurry (intersectSegSeg p1 x) $ _wlLine wl @@ -107,7 +110,7 @@ collidePointUpToIndirectMinDist -> IM.IntMap Wall -> Point2 {-# INLINE collidePointUpToIndirectMinDist #-} -collidePointUpToIndirectMinDist p1 p2 md = ssfold prop f p2 . IM.filter (not . _wlIsSeeThrough) +collidePointUpToIndirectMinDist p1 p2 md = ssfold prop f p2 . IM.filter wlIsOpaque where f x wl = fromMaybe x . uncurry (intersectSegSeg p1 x) $ _wlLine wl prop p3 = dist p1 p3 < md @@ -121,7 +124,7 @@ ssfold p f a0 xs = foldr (\x g a -> if p a then a else g (f a x)) id xs a0 collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 {-# INLINE collidePointIndirect #-} -collidePointIndirect p1 p2 = test . foldr f p2 . IM.filter (not . _wlIsSeeThrough) +collidePointIndirect p1 p2 = test . foldr f p2 . IM.filter wlIsOpaque where f wl p = fromMaybe p $ uncurry (intersectSegSeg p1 p) $ _wlLine wl test p | p == p2 = Nothing @@ -131,7 +134,7 @@ collidePointIndirect' :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 {-# INLINE collidePointIndirect' #-} collidePointIndirect' p1 p2 = L.fold - . L.prefilter (not . _wlIsSeeThrough) + . L.prefilter wlIsOpaque . L.premapMaybe (uncurry (intersectSegSeg p1 p2) . _wlLine) $ L.minimumOn (dist p1) @@ -141,17 +144,15 @@ collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 collidePointFire p1 p2 ws = safeMinimumOn (dist p1) . IM.mapMaybe ( uncurry (intersectSegSeg p1 p2) . _wlLine ) - $ IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? wlBlockID))) ws + $ IM.filter (\wl -> not (_wlFireThrough wl) || wlIsOpaque wl) ws {- | Checks to see whether someone can fire bullets effectively between two points. - Not sure if this needs vision as well, need to make this uniform. -} collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool collidePointFireVision p1 p2 ws = any ( isJust . uncurry (intersectSegSeg p1 p2) . _wlLine) - $ IM.filter notBlockWindow ws + $ IM.filter theTest ws where - notBlockWindow wl = case wl ^? wlBlockID of - Just _ -> not $ _wlIsSeeThrough wl - Nothing -> True + theTest wl = not (_wlFireThrough wl) || wlIsOpaque wl -- the reason for using the dashed version is the hope that this will short -- circuit @@ -180,7 +181,7 @@ pathToPointFireable :: Int -> Point2 -> World -> Bool pathToPointFireable i p w = not . pointHitsWalls (_crPos $ _creatures w IM.! i) p - $ IM.filter (isNothing . (^? wlBlockID) ) $ wallsAlongLine p1 p w + $ IM.filter (not . _wlFireThrough ) $ wallsAlongLine p1 p w where p1 = _crPos (_creatures w IM.! i) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index bea6a9ebf..749f76150 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -57,6 +57,7 @@ data World = World , _particles :: ![Particle] , _walls :: !(IM.IntMap Wall) , _doors :: IM.IntMap Door + , _machines :: IM.IntMap Machine , _blocks :: IM.IntMap Block , _wallsZone :: Zone (IM.IntMap Wall) , _floorItems :: IM.IntMap FloorItem @@ -549,6 +550,16 @@ data Block = Block , _blHPs :: [Int] , _blShadows :: [Int] } +data Machine = Machine + { _mcID :: Int + , _mcWallIDs :: [Int] + , _mcUpdate :: Machine -> World -> World + , _mcDraw :: Machine -> SPic + , _mcPos :: Point2 + , _mcDir :: Float + , _mcHP :: Int + , _mcSensor :: Int + } data Door = Door { _drID :: Int , _drWallIDs :: [Int] @@ -559,16 +570,27 @@ data Door = Door data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int deriving (Eq, Ord, Show) data Wall = Wall - { _wlLine :: (Point2,Point2) - , _wlID :: Int - , _wlColor :: Color - , _wlSeen :: Bool - , _wlIsSeeThrough :: Bool - , _wlPathable :: Bool - , _wlDraw :: Bool - , _wlRotateTo :: Bool - , _wlBlockID :: Maybe' Int + { _wlLine :: (Point2,Point2) + , _wlID :: Int + , _wlColor :: Color + , _wlSeen :: Bool + , _wlOpacity :: Opacity + , _wlPathable :: Bool + , _wlFireThrough :: Bool + , _wlDraw :: Bool + , _wlRotateTo :: Bool + , _wlStructure :: WallStructure } +data Opacity + = SeeThrough + | SeeAbove + | Opaque + deriving (Eq,Ord,Show) +data WallStructure + = StandaloneWall + | DoorPart { _wlStDoor :: Int } + | MachinePart { _wlStMachine :: Int } + | BlockPart { _wlStBlock :: Int } -- | Strict maybe data Maybe' a = Just' a | Nothing' @@ -749,6 +771,7 @@ makeLenses ''PjParam makeLenses ''Prop makeLenses ''Particle makeLenses ''Wall +makeLenses ''WallStructure makeLenses ''PressPlate makeLenses ''Button makeLenses ''ActionPlan @@ -759,5 +782,6 @@ makeLenses ''CrMvType makeLenses ''Intention makeLenses ''Door makeLenses ''Block +makeLenses ''Machine makeLenses ''Zone makeLenses ''ItemDimension diff --git a/src/Dodge/Data/DamageType.hs b/src/Dodge/Data/DamageType.hs index 7f6332cf4..49fa789d2 100644 --- a/src/Dodge/Data/DamageType.hs +++ b/src/Dodge/Data/DamageType.hs @@ -14,6 +14,7 @@ import Control.Lens data DamageType = Piercing {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } | Blunt {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } + | Cutting {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } | SparkDam {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } | Flaming {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } | Lasering {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 } diff --git a/src/Dodge/Debug/Picture.hs b/src/Dodge/Debug/Picture.hs index 6ff008d98..f6ce5aa17 100644 --- a/src/Dodge/Debug/Picture.hs +++ b/src/Dodge/Debug/Picture.hs @@ -43,7 +43,7 @@ lineOnScreenCone w p1 p2 = pointInPolygon p1 sp drawWallFace :: World -> Wall -> Picture drawWallFace w wall - | isRHS sightFrom x y || _wlIsSeeThrough wall = blank + | isRHS sightFrom x y || _wlOpacity wall /= Opaque = blank | otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points where (x,y) = _wlLine wall @@ -56,13 +56,13 @@ extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] + borderPs = mapMaybe (intersectLinefromScreen w c) [x,y] cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg y ((2*.*y) -.- x)) - . makeLoopPairs $ screenPolygon w + . loopPairs $ screenPolygon w -- the following assumes that the point a is inside the screen -- it still works otherwise, but it might intersect two points: -- it is not obvious which will be returned intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2 intersectLinefromScreen w a b = listToMaybe - . mapMaybe (\(x,y) -> intersectSegLineFrom' x y b (b +.+ b -.- a)) - . makeLoopPairs + . mapMaybe (\(x,y) -> intersectSegLineFrom x y b (b +.+ b -.- a)) + . loopPairs $ screenPolygon w diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index a38d96817..fd927c0af 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -62,6 +62,7 @@ defaultCreature = Creature , _crGroup = LoneWolf , _crMvType = defaultAimMvType } + defaultCreatureMemory :: MemoryState defaultCreatureMemory = MemoryState { _soundsToInvestigate = [] @@ -208,6 +209,18 @@ defaultIt = Consumable , _itHammer = HammerUp , _itAimStance = LeaveHolstered } +defaultMachine :: Machine +defaultMachine = Machine + { _mcID = 0 + , _mcWallIDs = [] + , _mcUpdate = const id + , _mcDraw = const mempty + , _mcPos = V2 0 0 + , _mcDir = 0 + , _mcHP = 100 + , _mcSensor = 0 + } + defaultDrawButton :: Color -> Button -> SPic defaultDrawButton col bt = ( translateSHz 15 . colorSH col $ upperPrismPoly 5 buttonGeometry diff --git a/src/Dodge/Default/Wall.hs b/src/Dodge/Default/Wall.hs index 388a0f6e5..a159b2a57 100644 --- a/src/Dodge/Default/Wall.hs +++ b/src/Dodge/Default/Wall.hs @@ -10,19 +10,23 @@ defaultWall = Wall , _wlID = 0 , _wlColor = greyN 0.6 , _wlSeen = False - , _wlIsSeeThrough = False - , _wlPathable = False + , _wlOpacity = Opaque + , _wlPathable = False + , _wlFireThrough = False , _wlDraw = True , _wlRotateTo = True - , _wlBlockID = Nothing' + , _wlStructure = StandaloneWall } {- Indestructible see-through wall. -} defaultCrystalWall :: Wall defaultCrystalWall = defaultWall - { _wlLine = (V2 0 0,V2 50 0) - , _wlID = 0 - , _wlColor = withAlpha 0.5 aquamarine - , _wlSeen = False - , _wlIsSeeThrough = True - , _wlPathable = False + { _wlColor = withAlpha 0.5 aquamarine + , _wlOpacity = SeeThrough + } +defaultMachineWall :: Wall +defaultMachineWall = defaultWall + { _wlOpacity = SeeAbove + , _wlDraw = False + , _wlRotateTo = False + , _wlStructure = MachinePart 0 } diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index 151c8c689..3126ad22b 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -36,6 +36,7 @@ defaultWorld = World , _particles = [] , _walls = IM.empty , _blocks = IM.empty + , _machines = IM.empty , _doors = IM.empty , _wallsZone = Zone IM.empty , _floorItems = IM.empty diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index c9b5a36f0..eee3d90c4 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -189,7 +189,7 @@ moveLaser phaseV pos dir w pt f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either Creature Wall),[Point2]) f seenWs x y = case find (h' seenWs) $ thingsHitExceptCrLongLine Nothing x y w of Just (p,Right wl) - | _wlIsSeeThrough wl -> f' p $ f (wl:seenWs) p (h x y wl p) + | _wlOpacity wl == SeeThrough -> f' p $ f (wl:seenWs) p (h x y wl p) | otherwise -> (Just (p,Right wl), [p]) Just (p,obj) -> (Just (p,obj), [p]) Nothing -> (Nothing, [y]) diff --git a/src/Dodge/Item/Weapon/BulletGuns.hs b/src/Dodge/Item/Weapon/BulletGuns.hs index a2f53ed22..e4c13d195 100644 --- a/src/Dodge/Item/Weapon/BulletGuns.hs +++ b/src/Dodge/Item/Weapon/BulletGuns.hs @@ -267,7 +267,7 @@ miniGun = defaultAutoGun , _itAimingRange = 1 , _itEquipPict = pictureWeaponAim miniGunPictItem , _wpAmmo = basicBullet - } + } & itDimension . muzzleLength .~ 15 where recoilAmount = 5 [vm1,vm2,vm3,vm4] = diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 5dd8605c0..b50f78d24 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -16,10 +16,12 @@ import Dodge.LevelGen.AutoDoor import Dodge.LevelGen.TriggerDoor import Dodge.LevelGen.Switch import Dodge.LevelGen.Data +import Dodge.Default.Wall import Geometry import Geometry.Vector3D import Shape import qualified IntMapHelp as IM +import Color import Control.Monad.State import Control.Lens @@ -46,30 +48,30 @@ placeSpotID ps w = case _psType ps of PutButton bt -> placeBt bt p rot w PutFlIt itm -> placeFlIt itm p rot w PutCrit cr -> placeCr cr p rot w + PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w PutLS ls -> placeLS ls p' rot w PutPressPlate pp -> placePressPlate pp p rot w RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w) where (evaluatedType, g) = runState rgen (_randGen w) - PutDoor col f pss -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w + PutDoor col f pss -> putDoor col f (map (mapBoth doShift) pss) w where mapBoth fn (x,y) = (fn x, fn y) PutSingleDoor col f a b speed - -> putSingleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w + -> putSingleDoor False col f (doShift a) (doShift b) speed w PutDoubleDoor col f a b speed - -> (,) 0 $ insertDoubleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w - PutAutoDoor a b -> (,) 0 $ addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w - PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w + -> (,) 0 $ insertDoubleDoor False col f (doShift a) (doShift b) speed w + PutAutoDoor a b -> (,) 0 $ addAutoDoor (doShift a) (doShift b) w + PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w PutBlock{} -> error "messed up block placement somehow" - PutBtDoor c bp f a b speed - -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) - (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w + PutBtDoor c bp f a b speed -> addButtonDoor c (doShift bp) (f + rot) + (doShift a) (doShift b) speed w PutLineBlock wl width depth a b - -> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w - PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls (q:qs) wl) w) + -> putLineBlock wl width depth (doShift a) (doShift b) w + PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w) where - (q:qs) = map (shiftPointBy (p,rot)) ps' - rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q]) + qs = map doShift ps' + rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ loopPairs qs PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>)) PutNothing -> (0,w) PutID i -> (i, w) @@ -78,6 +80,7 @@ placeSpotID ps w = case _psType ps of p@(V2 px py) = _psPos ps p' = V3 px py 0 rot = _psRot ps + doShift = shiftPointBy (p,rot) -- TODO: remove this typeclass class Shiftable a where @@ -179,13 +182,29 @@ placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr) cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} placeCr :: Creature -> Point2 -> Float -> World -> (Int,World) -placeCr crF p rot w = (i, over creatures addCr w) +placeCr crF p rot w = (cid, over creatures addCr w) where - i = IM.newKey $ _creatures w - addCr crs = IM.insert - (IM.newKey crs) - (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = IM.newKey crs}) - crs + cid = IM.newKey $ _creatures w + addCr crs = IM.insert cid (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}) crs + +placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World) +placeMachine color wallpoly mc p rot w = (mcid + , w & machines %~ addMc + & walls %~ placeMachineWalls color wallpoly mcid wlid + ) + where + mcid = IM.newKey $ _machines w + wlid = IM.newKey $ _walls w + wlids = [wlid .. wlid + length wallpoly] + addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs +-- 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 + where + f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l} + baseWall = defaultMachineWall + & wlColor .~ col + & wlStructure . wlStMachine .~ mcid placeLS :: LightSource -> Point3 -> Float -> World -> (Int,World) placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w) diff --git a/src/Dodge/LevelGen/Block.hs b/src/Dodge/LevelGen/Block.hs index abbf784ba..5767ea329 100644 --- a/src/Dodge/LevelGen/Block.hs +++ b/src/Dodge/LevelGen/Block.hs @@ -1,6 +1,6 @@ {- | Creation, update and destruction of destructible walls. -} module Dodge.LevelGen.Block - ( putBlock + ( placeBlock , putLineBlock ) where @@ -20,13 +20,13 @@ addBlock :: [Point2] -- ^ Block polygon -> Int -- ^ First layer of health -> Color - -> Bool -- ^ Is the block see through? + -> Opacity -- ^ Is the block see through? -> [Int] -- ^ Extra layers of health -> World -> World -addBlock (p:ps) hp col isSeeThrough hps w +addBlock (p:ps) hp col opacity hps w | hp <= 0 && null hps = w - | hp <= 0 = addBlock (p:ps) (head hps + hp) col isSeeThrough (tail hps) w + | hp <= 0 = addBlock (p:ps) (head hps + hp) col opacity (tail hps) w | otherwise = w & wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes & walls %~ IM.union panes @@ -41,8 +41,9 @@ addBlock (p:ps) hp col isSeeThrough hps w { _wlLine = (a,b) , _wlID = j , _wlColor = col - , _wlIsSeeThrough = isSeeThrough - , _wlBlockID = Just' blid + , _wlOpacity = opacity + , _wlStructure = BlockPart blid + , _wlFireThrough = True } ) is lns wallInZone wl @@ -55,12 +56,11 @@ addBlock (p:ps) hp col isSeeThrough hps w ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl) addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon" -putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> (Int,World) -putBlock (p:ps) i c b is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs) +placeBlock :: [Point2] -> Int -> Color -> Opacity -> [Int] -> World -> (Int,World) +placeBlock poly i c opac is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs) where - pairs = zip (p:ps) (ps ++ [p]) - wWithBlock = addBlock (p:ps) i c b is w -putBlock _ _ _ _ _ _ = error "Trying to put a block with incomplete polygon" + pairs = loopPairs poly + wWithBlock = addBlock poly i c opac is w {- | Splits a line into many four cornered blocks. -} putLineBlock @@ -83,7 +83,7 @@ putLineBlock basePane blockWidth depth a b w = (,) 0 is = [0.. numBlocks - 1] cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints - linesAt p = makeLoopPairs $ cornersAt p + linesAt p = loopPairs $ cornersAt p k = IM.newKey $ _walls w blid = IM.newKey $ _blocks w insertBlock i = over blocks $ IM.insert (i+blid) Block @@ -101,7 +101,7 @@ putLineBlock basePane blockWidth depth a b w = (,) 0 makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p) makePane i visStatus k' ps = basePane {_wlID = k' - ,_wlBlockID = Just' $ i + blid + ,_wlStructure = BlockPart $ i + blid ,_wlLine = ps ,_wlDraw = visStatus } diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 789c7e805..3d3071c19 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -11,6 +11,7 @@ import Control.Lens import Control.Monad.State import System.Random data PSType = PutCrit {_unPutCrit :: Creature} + | PutMachine Color [Point2] Machine | PutLS LightSource | PutButton Button | PutProp Prop diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs index fcf5ccc41..4d51b8ead 100644 --- a/src/Dodge/LevelGen/TriggerDoor.hs +++ b/src/Dodge/LevelGen/TriggerDoor.hs @@ -72,7 +72,7 @@ putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor) , _wlID = wlid , _wlColor = col , _wlSeen = False - , _wlIsSeeThrough = False + , _wlOpacity = Opaque , _wlPathable = False } -- TODO use vector instead of list, perhaps also memoisation of rectanglePairs @@ -146,9 +146,9 @@ putSingleDoor isPathable col cond a b speed w = (drid, addWalls w { _wlLine = wlps , _wlID = wlid , _wlColor = col - , _wlSeen = False - , _wlIsSeeThrough = False - , _wlPathable = isPathable + , _wlSeen = False + , _wlOpacity = Opaque + , _wlPathable = isPathable } pairs = rectanglePairs 9 a b shiftedPairs = map (bimap shiftLeft shiftLeft) pairs diff --git a/src/Dodge/Machine/Sensor.hs b/src/Dodge/Machine/Sensor.hs new file mode 100644 index 000000000..cce70c208 --- /dev/null +++ b/src/Dodge/Machine/Sensor.hs @@ -0,0 +1,21 @@ +module Dodge.Machine.Sensor + ( lightSensor + ) where +import Color +import Dodge.Data +import Dodge.LevelGen.Data +import Dodge.Default +import Geometry +import ShapePicture +import Shape + +lightSensor :: PSType +lightSensor = PutMachine blue (reverse $ square wdth) defaultMachine + { _mcDraw = const lightSensorSPic } + +lightSensorSPic :: SPic +lightSensorSPic = ( colorSH blue $ upperPrismPoly 25 (square wdth) + , mempty ) + +wdth :: Float +wdth = 5 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 534e6dc80..31f3d7a0c 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -138,9 +138,8 @@ lineOnScreen w p1 p2 = pointInPolygon p1 sp sp = screenPolygon w sps = zip sp (tail sp ++ [head sp]) - drawWallFloor :: Wall -> Picture -drawWallFloor wl = if _wlIsSeeThrough wl +drawWallFloor wl = if _wlOpacity wl == SeeThrough then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y] else blank where @@ -159,7 +158,8 @@ wallsAndWindows w = (map f wls, map f wins) where f wl = (_wlLine wl, _wlColor wl) - (wins,wls) = partition _wlIsSeeThrough . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen w + (wins,wls) = partition theTest . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen w + theTest wl = _wlOpacity wl /= Opaque lightsForGloom :: World -> [(Point3,Float,Point3)] lightsForGloom w = mapMaybe getLS (IM.elems $ _lightSources w) ++ mapMaybe getTLS (_tempLightSources w) diff --git a/src/Dodge/Render/Shape.hs b/src/Dodge/Render/Shape.hs index d84149197..44b323218 100644 --- a/src/Dodge/Render/Shape.hs +++ b/src/Dodge/Render/Shape.hs @@ -17,11 +17,15 @@ worldShape w = _foregroundShape w <> foldMap (_spShape . floorItemSPic) (IM.filter (pointIsClose . _flItPos) $ _floorItems w) <> foldMap (_spShape . dbArg _prDraw) (IM.filter (pointIsClose . _pjPos) $ _props w) <> foldMap btShape (IM.filter (pointIsClose . _btPos) $ _buttons w) + <> foldMap mcShape (IM.filter (pointIsClose . _mcPos) $ _machines w) where pointIsClose p = dist camCen p < winSize winSize = 30 + max (getWindowX w) (getWindowY w) camCen = _cameraCenter w +mcShape :: Machine -> Shape +mcShape mc = uncurryV translateSHf (_mcPos mc) $ rotateSH (_mcDir mc) $ _spShape $ _mcDraw mc mc + btShape :: Button -> Shape btShape bt = uncurryV translateSHf (_btPos bt) $ rotateSH (_btRot bt) (_spShape $ _btPict bt bt) diff --git a/src/Dodge/Room/Placement.hs b/src/Dodge/Room/Placement.hs index 290ad5abf..8eb02f362 100644 --- a/src/Dodge/Room/Placement.hs +++ b/src/Dodge/Room/Placement.hs @@ -96,8 +96,9 @@ baseBlockPane = defaultWall , _wlID = 0 , _wlColor = greyN 0.5 , _wlSeen = False - , _wlIsSeeThrough = False + , _wlOpacity = Opaque , _wlDraw = True + , _wlFireThrough = True } baseWindowPane :: Wall baseWindowPane = defaultWall @@ -105,8 +106,9 @@ baseWindowPane = defaultWall , _wlID = 0 , _wlColor = withAlpha 0.2 cyan , _wlSeen = False - , _wlIsSeeThrough = True + , _wlOpacity = SeeThrough , _wlDraw = True + , _wlFireThrough = True } {- Replaces instances of a given 'PutID' with 'PSType's drawn from a list. -} replacePutID diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 5cd20696f..7ad37fe78 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -9,6 +9,7 @@ import Dodge.Room.Furniture import Dodge.Layout.Tree.Polymorphic import Dodge.LevelGen.Data import Dodge.LightSources.Fitting +import Dodge.Machine.Sensor import Geometry.Data import Color import Shape @@ -36,6 +37,7 @@ startRoom = do , tankSquareEmboss4 (dim orange) 50 (h-60) , tankSquare (dim orange) 50 50 , tankSquare (dim orange) 50 120 + , sPS (V2 (0.8*w) (0.25*h)) 0 lightSensor , sps0 $ PutForeground $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25) ] ) diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 82c5d6223..75360c223 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -90,8 +90,8 @@ splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardC ps = map (fst . _wlLine) wls cen = centroid ps theSoundEffect - | _wlIsSeeThrough (head wls) = mkSoundSplinterGlass - | otherwise = mkSoundSplinterBlock + | _wlOpacity (head wls) == SeeThrough = mkSoundSplinterGlass + | otherwise = mkSoundSplinterBlock unshadowBlock :: Int -> World -> World unshadowBlock wlid w = case w ^? walls . ix wlid of @@ -298,7 +298,7 @@ rotateToOverlappingWall w = case theWall of {- Finds the visible walls from a point to another point. -} visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall] visibleWalls p1 p2 ws - = takeUntil _wlIsSeeThrough + = takeUntil theTest . map snd . sortOn (dist p1 . fromJust . fst) . filter (isJust . fst) @@ -306,3 +306,4 @@ visibleWalls p1 p2 ws $ IM.elems ws where f wl = (uncurry intersectSegSeg (_wlLine wl) p1 p2, wl) + theTest wl = _wlOpacity wl /= Opaque diff --git a/src/Dodge/WorldEvent/DamageBlock.hs b/src/Dodge/WorldEvent/DamageBlock.hs index 0ae0e301c..599b0490f 100644 --- a/src/Dodge/WorldEvent/DamageBlock.hs +++ b/src/Dodge/WorldEvent/DamageBlock.hs @@ -6,9 +6,9 @@ import Dodge.Data import Control.Lens damageBlocksBy :: Int -> Wall -> World -> World -damageBlocksBy x wl = case _wlBlockID wl of - Just' blid -> blocks . ix blid . blHPs %~ reduceHeadBy x - Nothing' -> id +damageBlocksBy x wl = case wl ^? wlStructure . wlStBlock of + Just blid -> blocks . ix blid . blHPs %~ reduceHeadBy x + Nothing -> id where reduceHeadBy y (z:zs) = z - y : zs reduceHeadBy _ [] = [] diff --git a/src/Dodge/WorldEvent/HitEffect.hs b/src/Dodge/WorldEvent/HitEffect.hs index 83032ad01..a09074777 100644 --- a/src/Dodge/WorldEvent/HitEffect.hs +++ b/src/Dodge/WorldEvent/HitEffect.hs @@ -10,7 +10,6 @@ import Dodge.Creature.State.Data import Geometry import Data.Bifunctor -import Data.Maybe import Control.Lens type HitCreatureEffect = Particle -> Point2 -> Creature -> World -> World @@ -67,7 +66,7 @@ penWalls penWalls crEff wlEff pt hitThings w = case hitThings of [] -> ( w, mvPt pt) ((p,Left cr):_) -> (crEff pt p cr w, destroyAt p pt) - ((p,Right wl):hs) | isJust (wl ^? wlBlockID) + ((p,Right wl):hs) | _wlFireThrough wl -> first (wlEff pt p wl) $ penWalls crEff wlEff pt hs w ((p,Right wl):_) -> (wlEff pt p wl w, destroyAt p pt) diff --git a/src/Geometry.hs b/src/Geometry.hs index d062c3dc0..f1e5faa2d 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -449,10 +449,10 @@ arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots -- | Given a list of points, returns pairs of points linking the points into a -- loop. -makeLoopPairs :: [Point2] -> [(Point2,Point2)] -makeLoopPairs [] = error "tried to make loop with empty list of points" -makeLoopPairs [_] = error "tried to make loop with singleton list of points" -makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x]) +loopPairs :: [Point2] -> [(Point2,Point2)] +loopPairs [] = error "tried to make loop with empty list of points" +loopPairs [_] = error "tried to make loop with singleton list of points" +loopPairs (x:xs) = zip (x:xs) (xs ++ [x]) -- | Test whether a point is in a cone. -- Note the pair is ordered. -- Doesn't work for obtuse angles. diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index 5fe2a526f..9c4c47e03 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -34,9 +34,9 @@ intersectSegSeg (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) -- | Intended to intersect a segment with a half-line-segment, ie a segment -- extending infinitely in one direction. -intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 -{-# INLINE intersectSegLineFrom' #-} -intersectSegLineFrom' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) +intersectSegLineFrom :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 +{-# INLINE intersectSegLineFrom #-} +intersectSegLineFrom (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4) | den == 0 = Nothing | den > 0 && ( t' < 0 || u' < 0 || t' > den ) = Nothing