Add objects based on walls, called machines

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
+    theTest wl = not (_wlFireThrough wl) || wlIsOpaque wl
-        Just _  -> not $ _wlIsSeeThrough wl
-        Nothing -> True
 
 -- 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)
 

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) 
+    { _wlLine       :: (Point2,Point2) 
-    , _wlID :: Int 
+    , _wlID         :: Int 
-    , _wlColor :: Color
+    , _wlColor      :: Color
-    , _wlSeen :: Bool
+    , _wlSeen       :: Bool
-    , _wlIsSeeThrough :: Bool
+    , _wlOpacity    :: Opacity
-    , _wlPathable :: Bool
+    , _wlPathable   :: Bool
-    , _wlDraw :: Bool
+    , _wlFireThrough :: Bool
-    , _wlRotateTo :: Bool
+    , _wlDraw       :: Bool
-    , _wlBlockID  :: Maybe' Int
+    , _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

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 }

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))
+    . mapMaybe (\(x,y) -> intersectSegLineFrom x y b (b +.+ b -.- a))
-    . makeLoopPairs 
+    . loopPairs 
     $ screenPolygon w

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

src/Dodge/Default/Wall.hs

@@ -10,19 +10,23 @@ defaultWall = Wall
     , _wlID = 0
     , _wlColor = greyN 0.6
     , _wlSeen = False
-    , _wlIsSeeThrough = False
+    , _wlOpacity    = Opaque
-    , _wlPathable = False
+    , _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)
+    { _wlColor = withAlpha 0.5 aquamarine
-    , _wlID = 0
+    , _wlOpacity = SeeThrough
-    , _wlColor = withAlpha 0.5 aquamarine
+    }
-    , _wlSeen = False
+defaultMachineWall :: Wall
-    , _wlIsSeeThrough = True
+defaultMachineWall = defaultWall
-    , _wlPathable = False
+    { _wlOpacity = SeeAbove
+    , _wlDraw = False
+    , _wlRotateTo = False
+    , _wlStructure = MachinePart 0
     }

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

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])

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] = 

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
+        -> (,) 0 $ insertDoubleDoor False col f (doShift a) (doShift b) speed w
-    PutAutoDoor a b -> (,) 0 $ addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
+    PutAutoDoor a b -> (,) 0 $ addAutoDoor (doShift a) (doShift b) w
-    PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps 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 
+    PutBtDoor c bp f a b speed -> addButtonDoor c (doShift bp) (f + rot) 
-        -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) 
+                            (doShift a) (doShift b) speed w
-                            (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
     PutLineBlock wl width depth a b
-        -> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
+        -> putLineBlock wl width depth (doShift a) (doShift b) w
-    PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls (q:qs) wl) w)
+    PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)
       where 
-        (q:qs) = map (shiftPointBy (p,rot)) ps'
+        qs = map doShift ps'
-        rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q])
+        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
+    cid = IM.newKey $ _creatures w
-    addCr crs = IM.insert 
+    addCr crs = IM.insert cid (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}) crs
-        (IM.newKey crs) 
+
-        (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = IM.newKey crs}) 
+placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
-        crs
+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)

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
+            , _wlOpacity = opacity
-            , _wlBlockID = Just' blid
+            , _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)
+placeBlock :: [Point2] -> Int -> Color -> Opacity -> [Int] -> World -> (Int,World)
-putBlock (p:ps) i c b is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
+placeBlock poly i c opac is w = (0, foldr (uncurry removePathsCrossing) wWithBlock pairs)
   where 
-    pairs = zip (p:ps) (ps ++ [p])
+    pairs = loopPairs poly
-    wWithBlock = addBlock (p:ps) i c b is w
+    wWithBlock = addBlock poly i c opac is w
-putBlock _ _ _ _ _ _ = error "Trying to put a block with incomplete polygon"
 
 {- | 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
         }

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

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
+        , _wlSeen       = False
-        , _wlIsSeeThrough = False
+        , _wlOpacity    = Opaque
-        , _wlPathable = isPathable
+        , _wlPathable   = isPathable
         }
     pairs = rectanglePairs 9 a b
     shiftedPairs = map (bimap shiftLeft shiftLeft) pairs

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

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)

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)
 

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 

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)
             ]
             )

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
+        | _wlOpacity (head wls) == SeeThrough = mkSoundSplinterGlass
-        | otherwise                  = mkSoundSplinterBlock
+        | 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

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
+damageBlocksBy x wl = case wl ^? wlStructure . wlStBlock of
-    Just' blid -> blocks . ix blid . blHPs %~ reduceHeadBy x
+    Just blid -> blocks . ix blid . blHPs %~ reduceHeadBy x
-    Nothing'   -> id
+    Nothing   -> id
   where
     reduceHeadBy y (z:zs) = z - y : zs
     reduceHeadBy _ [] = []

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)
 

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)]
+loopPairs :: [Point2] -> [(Point2,Point2)]
-makeLoopPairs [] = error "tried to make loop with empty list of points"
+loopPairs [] = error "tried to make loop with empty list of points"
-makeLoopPairs [_] = error "tried to make loop with singleton list of points"
+loopPairs [_] = error "tried to make loop with singleton list of points"
-makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x])
+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.

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
+intersectSegLineFrom :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
-{-# INLINE intersectSegLineFrom' #-}
+{-# INLINE intersectSegLineFrom #-}
-intersectSegLineFrom' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
+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