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

Simplify analyser machines somewhat

Browse Source
This commit is contained in:
justin
2025-09-16 21:41:26 +01:00
parent 203919933c
commit 81d6727d8e
21 changed files with 418 additions and 464 deletions
Download Patch File Download Diff File Expand all files Collapse all files
saveSlot/LevelStart0
+1 -1
View File
File diff suppressed because one or more lines are too long
saveSlot/QuickSave
+1 -1
View File
File diff suppressed because one or more lines are too long
src/Dodge/Base/Window.hs
+1 -1
View File
@@ -57,4 +57,4 @@ screenBox w = rectNSWE hh (- hh) (- hw) hw
hh = halfHeight w
pointIsOnScreen :: Config -> Camera -> Point2 -> Bool
pointIsOnScreen cfig w p = pointInPolygon p $ screenPolygon cfig w
pointIsOnScreen cfig = flip pointInPoly . screenPolygon cfig
src/Dodge/Data/Machine.hs
+3 -4
View File
@@ -26,7 +26,6 @@ import Dodge.Data.Machine.Sensor
import Dodge.Data.Material
import Dodge.Data.ObjectType
import Geometry.Data
import Sound.Data
data Machine = Machine
{ _mcID :: Int
@@ -39,8 +38,7 @@ data Machine = Machine
, _mcDamage :: [Damage]
, _mcType :: MachineType
, _mcMounts :: M.Map ObjectType Int
, _mcName :: String
, _mcCloseSound :: Maybe SoundID
-- , _mcCloseSound :: Maybe SoundID
, _mcWidth :: Float
}
--deriving (Eq, Show, Read) --, Generic)
@@ -49,7 +47,8 @@ data Machine = Machine
data MachineType
= McStatic
| McTerminal
| McSensor Sensor
| McDamSensor DamageSensor
| McProxSensor ProximitySensor
| McTurret {_mctTurret :: Turret}
--deriving (Eq, Show, Read) --, Generic)
--hderiving (Eq, Show, Read) --Generic, Flat)
src/Dodge/Data/Machine/Sensor.hs
+9 -17
View File
@@ -17,19 +17,17 @@ import Dodge.Data.GenParams
import Dodge.Data.Item.Combine
import Dodge.Data.Machine.Sensor.Type
data Sensor
= DamageSensor
data DamageSensor = DamSensor
{ _sensToggle :: Bool
, _sensAmount :: Int
, _sensType :: SensorType
, _sensDraw :: (PaletteColor, DecorationShape)
, _sensThreshold :: Int
}
| ProximitySensor
{ _proxStatus :: CloseToggle
, _proxDist :: Float
, _proxRequirement :: ProximityRequirement
, _sensToggle :: Bool
data ProximitySensor = ProxSensor
{ _proxRequirement :: ProximityRequirement
, _proxToggle :: Bool
}
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
@@ -40,15 +38,9 @@ data ProximityRequirement
| RequireNoItems {_proxNoItems :: [Point2]}
deriving (Show)
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
data CloseToggle = NotClose | IsClose
deriving (Show)
--deriving (Eq, Ord, Show, Read) --Generic, Flat)
makeLenses ''Sensor
makeLenses ''DamageSensor
makeLenses ''ProximitySensor
makeLenses ''ProximityRequirement
deriveJSON defaultOptions ''ProximityRequirement
deriveJSON defaultOptions ''CloseToggle
deriveJSON defaultOptions ''Sensor
deriveJSON defaultOptions ''ProximitySensor
deriveJSON defaultOptions ''DamageSensor
src/Dodge/Debug/Picture.hs
+4 -4
View File
@@ -58,14 +58,14 @@ outsideScreenPolygon cfig w = [tr, tl, bl, br]
-- towards the center of sight
lineOnScreenCone :: Config -> World -> Point2 -> Point2 -> Bool
lineOnScreenCone cfig w p1 p2 =
pointInPolygon p1 sp
|| pointInPolygon p2 sp
pointInPoly p1 sp
|| pointInPoly p2 sp
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
where
sp' = screenPolygon cfig (w ^. wCam)
vp = w ^. wCam . camViewFrom
sp
| pointInPolygon vp sp' = sp'
| pointInPoly vp sp' = sp'
| otherwise = orderPolygon ((w ^. wCam . camViewFrom) : sp')
sps = zip sp (tail sp ++ [head sp])
@@ -446,7 +446,7 @@ drawPathing cfig w =
edgeToPic :: [Point2] -> PathEdge -> Picture
edgeToPic poly pe
| not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
| not (pointInPoly sp poly) && not (pointInPoly ep poly) = mempty
| otherwise = drawPathEdge pe
where
sp = _peStart pe
src/Dodge/Default.hs
+5 -8
View File
@@ -39,9 +39,8 @@ defaultMachine =
, _mcMaterial = Electronics
, _mcDamage = []
, _mcType = McStatic
, _mcName = ""
, _mcMounts = mempty
, _mcCloseSound = Nothing
-- , _mcCloseSound = Nothing
, _mcWidth = 10
}
@@ -64,11 +63,9 @@ defaultPP =
, _ppText = "Pressure plate"
}
defaultProximitySensor :: Sensor
defaultProximitySensor :: ProximitySensor
defaultProximitySensor =
ProximitySensor
{ _proxStatus = NotClose
, _proxDist = 40
, _proxRequirement = RequireHealth 0
, _sensToggle = False
ProxSensor
{ _proxRequirement = RequireHealth 0
, _proxToggle = False
}
src/Dodge/Machine/Draw.hs
+9 -5
View File
@@ -17,12 +17,16 @@ drawMachine lw mc = case _mcType mc of
McStatic -> mempty
McTerminal -> terminalSPic lw mc
McTurret tu -> drawBaseMachine 20 mc <> drawTurret lw tu mc
McSensor se -> drawBaseMachine 25 mc <> drawSensor se mc
McDamSensor se -> drawBaseMachine 25 mc <> drawDamSensor se mc
McProxSensor se -> drawBaseMachine 25 mc <> drawProxSensor se mc
drawSensor :: Sensor -> Machine -> SPic
drawSensor sens = case sens of
DamageSensor{_sensDraw = pcds} -> sensorSPic pcds
ProximitySensor{} -> const mempty
drawDamSensor :: DamageSensor -> Machine -> SPic
drawDamSensor sens = case sens of
DamSensor{_sensDraw = pcds} -> sensorSPic pcds
drawProxSensor :: ProximitySensor -> Machine -> SPic
drawProxSensor sens = case sens of
ProxSensor{} -> const mempty
terminalSPic :: LWorld -> Machine -> SPic
terminalSPic lw = noPic . terminalShape lw
src/Dodge/Machine/Update.hs
+42 -42
View File
@@ -24,14 +24,15 @@ updateMachine mc
| otherwise =
mcApplyDamage (_mcDamage mc) mc
. mcPlaySound mc
. mcTypeUpdate mc
. mcTypeUpdate mc (_mcType mc)
mcTypeUpdate :: Machine -> World -> World
mcTypeUpdate mc = case mc ^. mcType of
mcTypeUpdate :: Machine -> MachineType -> World -> World
mcTypeUpdate mc = \case
McStatic -> id
McTerminal -> terminalScreenGlow mc
McTurret tu -> updateTurret (_tuTurnSpeed tu) mc
McSensor se -> mcSensorTriggerUpdate se mc . mcSensorUpdate se mc
McDamSensor se -> mcDamSensorTriggerUpdate se mc . mcDamSensorUpdate se mc
McProxSensor se -> mcProxSensorTriggerUpdate se mc . mcProxSensorUpdate se mc
terminalScreenGlow :: Machine -> World -> World
terminalScreenGlow mc w = fromMaybe w $ do
@@ -93,29 +94,33 @@ mcUseItem mc w = fromMaybe w $ do
guard (_tuFireTime tu > 0)
return $ mcUseHeld hit it mc w
mcSensorTriggerUpdate :: Sensor -> Machine -> World -> World
mcSensorTriggerUpdate se mc = fromMaybe id $ do
mcDamSensorTriggerUpdate :: DamageSensor -> Machine -> World -> World
mcDamSensorTriggerUpdate se mc = fromMaybe id $ do
trid <- mc ^? mcMounts . ix OTTrigger
bval <- mcTriggerVal se
return $ cWorld . lWorld . triggers . ix trid ||~ bval
mcTriggerVal :: Sensor -> Maybe Bool
mcTriggerVal se = case se of
ProximitySensor{} -> se ^? sensToggle
DamageSensor{} -> Just $ _sensAmount se > _sensThreshold se
mcProxSensorTriggerUpdate :: ProximitySensor -> Machine -> World -> World
mcProxSensorTriggerUpdate se mc = fromMaybe id $ do
trid <- mc ^? mcMounts . ix OTTrigger
bval <- se ^? proxToggle
return $ cWorld . lWorld . triggers . at trid ?~ bval
mcTriggerVal :: DamageSensor -> Maybe Bool
mcTriggerVal se = Just $ _sensAmount se > _sensThreshold se
mcPlaySound :: Machine -> World -> World
mcPlaySound mc w = case _mcCloseSound mc of
Just sid
| d < 100 ->
soundContinueVol (1 -0.01 * d) (MachineSound mid) (_mcPos mc) sid (Just 2) w
mcPlaySound mc w = case _mcType mc of
McTerminal | d < 100 ->
soundContinueVol (1 -0.01 * d)
(MachineSound mid) (_mcPos mc) fridgeHumS (Just 2) w
_ -> w
where
d = max 0 (dist (_crPos $ you w) (_mcPos mc) - 100)
mid = _mcID mc
mcApplyDamage :: [Damage] -> Machine -> World -> World
mcApplyDamage ds mc = case mc ^? mcType . _McSensor of
mcApplyDamage ds mc = case mc ^? mcType . _McDamSensor of
Nothing ->
mcpointer
%~ ((mcDamage .~ []) . (mcHP -~ sum (map _dmAmount ds)))
@@ -125,36 +130,31 @@ mcApplyDamage ds mc = case mc ^? mcType . _McSensor of
where
mcpointer = cWorld . lWorld . machines . ix (_mcID mc)
mcSensorUpdate :: Sensor -> Machine -> World -> World
mcSensorUpdate se mc w = case se of
s@DamageSensor{} -> senseDamage (_sensThreshold se) (_sensType s) mc w
ProximitySensor {_proxRequirement = x} -> mcProximitySensorUpdate mc x w
mcDamSensorUpdate :: DamageSensor -> Machine -> World -> World
mcDamSensorUpdate se mc w = senseDamage (_sensThreshold se) (_sensType se) mc w
mcProximitySensorUpdate :: Machine -> ProximityRequirement -> World -> World
mcProximitySensorUpdate mc x w = case ( _proxStatus sens
, _sensToggle sens
, mcProxTest mc w x
, dist (_crPos ycr) (_mcPos mc) < _proxDist sens
) of
(_, True, _, _) -> w
(_, False, True, True) ->
mcProxSensorUpdate :: ProximitySensor -> Machine -> World -> World
mcProxSensorUpdate se mc = case se ^. proxRequirement of
RequireNoItems xs -> id
_ -> mcProximitySensorUpdate mc se
mcProximitySensorUpdate :: Machine -> ProximitySensor -> World -> World
mcProximitySensorUpdate mc sens w
| sens ^. proxToggle || dist (_crPos ycr) (_mcPos mc) > 40 = w
| mcProxTest mc w (sens ^. proxRequirement) =
w
& cWorld . lWorld . machines . ix (_mcID mc) . mcType . _McSensor . sensToggle .~ True
& mcsenslens . proxToggle .~ True
& playsound dedaS
& cWorld . lWorld . machines . ix (_mcID mc) . mcType . _McSensor . proxStatus .~ IsClose
& cWorld . lWorld . terminals . ix (mc ^?! mcMounts . ix OTTerminal) . tmFutureLines .:~ makeTermLine "SENSOR SUCCESS!"
(NotClose, _, False, True) ->
w & playsound dedumS
& cWorld . lWorld . machines . ix (_mcID mc) . mcType . _McSensor . proxStatus .~ IsClose
& cWorld . lWorld . terminals . ix (mc ^?! mcMounts . ix OTTerminal) . tmFutureLines
.:~ makeTermLine ("SENSOR FAIL: REQUIRES " ++ sensorReqToString (mc ^?! mcType . _McSensor . proxRequirement))
(_, _, _, False) ->
w & cWorld . lWorld . machines . ix (_mcID mc) . mcType . _McSensor . proxStatus .~ NotClose
_ -> w
& mctermlens . tmFutureLines .:~ makeTermLine "SENSOR SUCCESS!"
| otherwise = w & playsound dedumS
& mctermlens . tmFutureLines
.:~ makeTermLine ("SENSOR FAIL: REQUIRES "
++ sensorReqToString (mc ^?! mcType . _McProxSensor . proxRequirement))
where
mctermlens = cWorld . lWorld . terminals . ix (mc ^?! mcMounts . ix OTTerminal)
mcsenslens = cWorld . lWorld . machines . ix (_mcID mc) . mcType . _McProxSensor
playsound sid = soundContinue (MachineAltSound (_mcID mc)) (_mcPos mc) sid Nothing
ycr = you w
sens = mc ^?! mcType . _McSensor
sensorReqToString :: ProximityRequirement -> String
sensorReqToString = \case
@@ -170,7 +170,7 @@ mcProxTest mc w = \case
(\itm -> _itType itm == ct)
((\k -> w ^?! cWorld . lWorld . items . ix k) <$> _crInv cr)
RequireNoItems ps -> (w ^?! cWorld . lWorld . creatures . ix 0 . crInv == mempty)
&& not (any ((`pointInPolygon` f ps) . _flItPos) (w ^. cWorld . lWorld . floorItems) )
&& not (any ((`pointInPoly` f ps) . _flItPos) (w ^. cWorld . lWorld . floorItems) )
where
cr = you w
f = fmap ((+ _mcPos mc) . rotateV (_mcDir mc))
@@ -180,7 +180,7 @@ senseDamage threshold dt mc =
(cWorld . lWorld . machines . ix mcid %~ upmc)
. updatels
where
upmc = mcType . _McSensor . sensAmount %~ min (100 * threshold) . max 0 . (+ newsense)
upmc = mcType . _McDamSensor . sensAmount %~ min (100 * threshold) . max 0 . (+ newsense)
mcid = _mcID mc
newsense
| x > 0 = x
@@ -188,7 +188,7 @@ senseDamage threshold dt mc =
where
f = sensorTypeDamages dt
x = sum . map _dmAmount $ filter f (_mcDamage mc)
ni = fromIntegral (mc ^?! mcType . _McSensor . sensAmount) / fromIntegral threshold
ni = fromIntegral (mc ^?! mcType . _McDamSensor . sensAmount) / fromIntegral threshold
updatels = fromMaybe id $ do
lsid <- mc ^? mcMounts . ix OTLightSource
return $ cWorld . lWorld . lightSources . ix lsid . lsParam . lsCol .~ V3 ni ni ni
src/Dodge/Placement/Instance/Analyser.hs
+1 -30
View File
@@ -20,33 +20,4 @@ analyser proxreq pslight psmc = extTrigLitPos pslight $ \tp ->
defaultMachine & mcColor .~ aquamarine
& mcType .~ McTerminal
& mcHP .~ 100
& mcType .~ McSensor (defaultProximitySensor{_proxRequirement = proxreq})
--this can probably be deleted
--mcProximitySensorUpdate :: Machine -> World -> World
--mcProximitySensorUpdate mc w = case
-- (_proxStatus sens
-- , _sensToggle sens
-- , mcProxTest mc w
-- , dist (_crPos ycr) (_mcPos mc) < _proxDist sens) of
-- (_,True,_,_) -> w
-- (_,False,True,True) -> w
-- & machines . ix (_mcID mc) . mcSensor . sensToggle .~ True
-- & playsound dedaS
-- & machines . ix (_mcID mc) . mcSensor . proxStatus .~ IsClose
-- (NotClose,_,False,True) -> w & playsound dedumS
-- & machines . ix (_mcID mc) . mcSensor . proxStatus .~ IsClose
-- (_,_,_,False) -> w & machines . ix (_mcID mc) . mcSensor . proxStatus .~ NotClose
-- _ -> w
-- where
-- playsound sid = soundContinue (MachineAltSound (_mcID mc)) (_mcPos mc) sid Nothing
-- ycr = you w
-- sens = _mcSensor mc
--
--mcProxTest :: Machine -> World -> Bool
--mcProxTest mc w = case mc ^? mcSensor . proxRequirement of
-- Just (RequireHealth x) -> _crHP cr >= x
-- Just (RequireEquipment ct) -> any (\itm -> _iyBase (_itType itm) == ct) (_crInv cr)
-- _ -> False
-- where
-- cr = you w
& mcType .~ McProxSensor (defaultProximitySensor{_proxRequirement = proxreq})
src/Dodge/Placement/Instance/Sensor.hs
+2 -2
View File
@@ -25,8 +25,8 @@ damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1) $
& mcMounts . at OTTrigger .~ mtrid
& mcMounts . at OTLightSource ?~ lsid
& mcType
.~ McSensor
( DamageSensor
.~ McDamSensor
( DamSensor
False
0
dt
src/Dodge/Placement/Instance/Terminal.hs
-2
View File
@@ -10,7 +10,6 @@ import Data.Maybe
import Dodge.Data.GenWorld
import Dodge.Default
import Dodge.LevelGen.PlacementHelper
import Dodge.SoundLogic
import Dodge.WorldEffect
import Geometry
import LensHelp
@@ -36,7 +35,6 @@ putTerminalFull f col mc tm =
(reverse $ square 10)
( mc & mcMounts . at OTButton ?~ fromJust (_plMID btpl)
& mcMounts . at OTTerminal .~ _plMID tmpl
& mcCloseSound ?~ fridgeHumS
)
defaultSensorWall
Nothing
src/Dodge/Render/Lights.hs
+1 -1
View File
@@ -23,7 +23,7 @@ lightsToRender cfig campos w = take (fromEnum $ cfig ^. graphics_num_shadow_cas
cbox = campos ^. camBoundBox
cpos = campos ^. camCenter
getlsparam ls
| not (pointInPolygon lpos cbox) && extraculltest = Nothing
| not (pointInPoly lpos cbox) && extraculltest = Nothing
| otherwise = Just (_lsPos ls, rad ^ (2 :: Int), _lsCol ls)
where
lpos = xyV3 $ _lsPos ls
src/Dodge/Render/ShapePicture.hs
+1 -1
View File
@@ -90,7 +90,7 @@ shiftDraw' fpos fdir fdraw x =
cullPoint :: Config -> World -> Point2 -> Bool
cullPoint cfig w p
| debugOn Close_shape_culling cfig = pointInPolygon p (w ^. wCam . camBoundBox)
| debugOn Close_shape_culling cfig = pointInPoly p (w ^. wCam . camBoundBox)
| otherwise = dist (w ^. wCam . camCenter) p < (w ^. wCam . camViewDistance)
extraPics :: Config -> Universe -> Picture
src/Dodge/Room/Airlock.hs
+5 -3
View File
@@ -30,7 +30,7 @@ decontamRoom :: State LayoutVars Room
decontamRoom = do
return $
defaultRoom
& rmPolys .~ [rectNSWE 100 0 0 40, switchcut]
& rmPolys .~ cutps
& rmLinks .~ muout lnks ++ muin [last lnks]
& rmPath .~ foldMap doublePairSet [(V2 20 95, V2 20 45), (V2 20 45, V2 20 5)]
& rmPmnts
@@ -40,11 +40,13 @@ decontamRoom = do
\_ _ -> Just $ putDoubleDoor DoorObstacle thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2
, invisibleWall $ rectNSWE 60 40 (-40) (-30)
, spanLightI (V2 (-2) 30) (V2 (-2) 70)
--, analyser (RequireHealth 100) (PS 50 0) (PS (V2 70 50) 0)
, analyser (RequireNoItems $ square 50) (PS 50 0) (PS (V2 70 50) 0)
, analyser (RequireNoItems $ ps) (PS 50 0) (PS mcpos 0)
]
& rmBound .~ [rectNSWE 75 15 0 40, switchcut]
where
mcpos = V2 70 50
cutps = [rectNSWE 100 0 0 40, switchcut]
ps = (\p -> p - mcpos) <$> orderPolygon (concat cutps)
thewall = switchWallCol col
switchcut = rectNSWE 65 35 (-40) 80
lnks =
src/Dodge/Room/Path.hs
+3 -9
View File
@@ -44,15 +44,9 @@ linksAndPath lnks subpth = S.fromList subpth <> foldMap linkClosest lnks
linksAndPath' :: [RoomLink] -> [(Point2, Point2)] -> S.Set (Point2, Point2)
linksAndPath' = linksAndPath . map lnkPosDir
testCrossWalls ::
[(Point2, Point2)] ->
(Point2, Point2) ->
Bool
testCrossWalls :: [(Point2, Point2)] -> (Point2, Point2) -> Bool
testCrossWalls wls (a, b) = not $ any (isJust . uncurry (intersectSegSeg a b)) wls
--extra test whether both members of the path edge are in some poly
pairInPolys ::
[[Point2]] ->
(Point2, Point2) ->
Bool
pairInPolys polys (a, b) = any (pointInPolygon a) polys && any (pointInPolygon b) polys
pairInPolys :: [[Point2]] -> (Point2, Point2) -> Bool
pairInPolys polys (a, b) = any (pointInPoly a) polys && any (pointInPoly b) polys
src/Geometry.hs
+1 -1
View File
@@ -48,7 +48,7 @@ errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool
errorPointInPolygon !i !p xs
| length xs == 1 = error "one point polygon"
| length xs == 2 = error "two point polygon"
| nub xs == xs = pointInPolygon p xs
| nub xs == xs = pointInPoly p xs
| otherwise = error $ "errorPointInPolygon " ++ show i
-- | Debug version of 'normalizeV'.
src/Geometry/ConvexPoly.hs
+2 -3
View File
@@ -19,7 +19,6 @@ import Data.Aeson
import Data.Aeson.TH
import Geometry.Data
import Geometry.Intersect
import Geometry.LHS
import Geometry.Polygon
import Geometry.Vector
@@ -59,8 +58,8 @@ convexPolysOverlap cp1 cp2 =
-- | Test whether two polygons intersect or if one is contained in the other.
polyPointsOverlap :: [Point2] -> [Point2] -> Bool
polyPointsOverlap (p : ps) (q : qs) =
pointInPolygon p (q : qs)
|| pointInPolygon q (p : ps)
pointInPoly p (q : qs)
|| pointInPoly q (p : ps)
|| polyPointsIntersect (p : ps) (q : qs)
polyPointsOverlap _ _ = False
src/Geometry/Polygon.hs
+3 -3
View File
@@ -63,9 +63,9 @@ pointInOrOnPolygon _ _ = undefined
{- | Test whether a point is strictly inside a polygon.
Supposes the points in the polygon are listed in anticlockwise order.
-}
pointInPolygon :: Point2 -> [Point2] -> Bool
pointInPolygon !p (x : xs) = all (\l -> uncurry isLHS l p) $ zip (x : xs) (xs ++ [x])
pointInPolygon _ [] = False
pointInPoly :: Point2 -> [Point2] -> Bool
pointInPoly !p (x : xs) = all (\l -> uncurry isLHS l p) $ zip (x : xs) (xs ++ [x])
pointInPoly _ [] = False
circInPolygon :: Point2 -> Float -> [Point2] -> Bool
circInPolygon !p !r (x : xs) = all f $ zip (x : xs) (xs ++ [x])
src/Grid.hs
+1 -1
View File
@@ -11,7 +11,7 @@ import Geometry
gridInPolygon :: Float -> [Point2] -> [Point2]
gridInPolygon gap ps =
filter (`pointInPolygon` ps)
filter (`pointInPoly` ps)
. maybe [] (boundedGrid gap)
. boundPoints
$ ps
tags
+323 -325
View File
File diff suppressed because it is too large Load Diff