Improve machines, tweak wall ids

src/Dodge/Data.hs

@@ -547,23 +547,24 @@ data Prop
 data Either3 a b c = E3x1 a | E3x2 b | E3x3 c
 data Block = Block
     { _blID      :: Int
-    , _blWallIDs :: [Int]
+    , _blWallIDs :: IS.IntSet
     , _blHPs     :: [Int]
     , _blShadows :: [Int]
     }
 data Machine = Machine
     { _mcID      :: Int
-    , _mcWallIDs :: [Int]
+    , _mcWallIDs :: IS.IntSet
     , _mcUpdate  :: Machine -> World -> World
     , _mcDraw    :: Machine -> SPic
     , _mcPos     :: Point2
     , _mcDir     :: Float
     , _mcHP      :: Int
     , _mcSensor  :: Int
+    , _mcDamage  :: [DamageType]
     }
 data Door = Door
     { _drID :: Int
-    , _drWallIDs :: [Int]
+    , _drWallIDs :: IS.IntSet
     , _drStatus  :: DoorStatus
     , _drTrigger :: World -> Bool
     , _drMech    :: Door -> World -> World

src/Dodge/Default.hs

@@ -17,6 +17,7 @@ import Dodge.Creature.Memory.Data
 import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
 import Dodge.Picture.Layer
+import Dodge.Wall.Delete
 import Geometry
 import Picture
 import ShapePicture
@@ -212,14 +213,23 @@ defaultIt = Consumable
 defaultMachine :: Machine
 defaultMachine = Machine
     { _mcID = 0
-    , _mcWallIDs = []
+    , _mcWallIDs = mempty
-    , _mcUpdate = const id
+    , _mcUpdate = defaultMachineUpdate
     , _mcDraw = const mempty
     , _mcPos = V2 0 0
     , _mcDir = 0
     , _mcHP = 100
     , _mcSensor = 0
+    , _mcDamage = []
     }
+defaultMachineUpdate :: Machine -> World -> World
+defaultMachineUpdate mc w 
+    | _mcHP mc < 1 = w & machines %~ IM.delete mcid
+        & deleteWallIDs (_mcWallIDs mc)
+    | otherwise = w & machines . ix mcid %~ ( (mcDamage .~ []) . (mcHP -~ dams) )
+  where
+    dams = sum $ map _dmAmount $ _mcDamage mc 
+    mcid = _mcID mc
 
 defaultDrawButton :: Color -> Button -> SPic
 defaultDrawButton col bt =

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -9,6 +9,7 @@ import Dodge.SoundLogic.LoadSound
 import Dodge.Creature.State.Data
 import Dodge.Data.DamageType
 import Dodge.WorldEvent
+import Dodge.WorldEvent.DamageBlock
 import Dodge.Default
 import Dodge.Item.Draw
 import Dodge.Item.Data
@@ -221,12 +222,12 @@ moveLaser phaseV pos dir w pt
     h' ws (_,Right wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws
     h' _ _ = True
     (thHit, ps) = f [] pos xp
-    hitEffect
+    hitEffect = case thHit of
-      = case thHit of
         Just (p,Left cr) 
-              -> over (creatures . ix (_crID cr) . crState . crDamage) ((:) $ Lasering 19 pos p xp)
+            -> creatures . ix (_crID cr) . crState . crDamage %~ (Lasering 19 pos p xp :)
         Just (p,Right wl) -> colSpark 8 (V4 20 (-5) 0 1) (p +.+ safeNormalizeV (pos -.- p))
                                                     (reflectDir wl)
+            . damageWall (Lasering 19 pos p xp) wl
         _   -> id
     pic = setLayer 1 $ pictures
         [ setDepth 19   . color (brightX 0 0.5 yellow) $ lineOfThickness 20 (pos:ps)

src/Dodge/LevelGen.hs

@@ -25,6 +25,7 @@ import Color
 
 import Control.Monad.State
 import Control.Lens
+import qualified Data.IntSet as IS
 
 placeSpot :: World -> ((Point2,Float) , Placement) -> World
 placeSpot w (shift, plmnt) =
@@ -195,7 +196,7 @@ placeMachine color wallpoly mc p rot w = (mcid
   where 
     mcid = IM.newKey $ _machines w
     wlid = IM.newKey $ _walls w
-    wlids = [wlid .. wlid + length wallpoly]
+    wlids = IS.fromList [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

src/Dodge/LevelGen/Block.hs

@@ -15,6 +15,7 @@ import Color
 
 import Control.Lens
 import Data.List
+import qualified Data.IntSet as IS
 
 addBlock 
     :: [Point2]     -- ^ Block polygon
@@ -30,7 +31,7 @@ addBlock (p:ps) hp col opacity hps w
     | otherwise = w
         & wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
         & walls  %~ IM.union panes
-        & blocks %~ IM.insert blid (Block {_blID = blid,_blWallIDs = is, _blHPs = hp:hps, _blShadows=[]})
+        & blocks %~ IM.insert blid (Block {_blID = blid,_blWallIDs = IS.fromList is, _blHPs = hp:hps, _blShadows=[]})
   where 
     blid = IM.newKey $ _blocks w
     lns = zip (p:ps) (ps ++ [p])
@@ -87,7 +88,7 @@ placeLineBlock basePane blockWidth depth a b w = (,) 0
     k = IM.newKey $ _walls w
     blid = IM.newKey $ _blocks w
     insertBlock i = over blocks $ IM.insert (i+blid) Block 
-        {_blID = i + blid, _blWallIDs = ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
+        {_blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
     insertBlocks = flip (foldr insertBlock) is
     ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
     visibilityAt i 

src/Dodge/LevelGen/TriggerDoor.hs

@@ -24,6 +24,7 @@ import Data.List
 import Data.Maybe
 import Control.Lens
 import Data.Graph.Inductive hiding ((&))
+import qualified Data.IntSet as IS
 
 -- probably don't have to rebuild the entire graph, oh well
 addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World)
@@ -58,7 +59,7 @@ putDoor col cond pss w = (drid, addWalls w & doors %~ addDoor)
     drid = IM.newKey $ _doors w
     addDoor = IM.insert drid $ Door
         { _drID = drid
-        , _drWallIDs = wlids
+        , _drWallIDs = IS.fromList wlids
         , _drStatus = DoorInt 0
         , _drTrigger = cond
         , _drMech   = doorMechanismStepwise nsteps drid wlids pss
@@ -136,7 +137,7 @@ putSingleDoor isPathable col cond a b speed w = (drid, addWalls w
     drid = IM.newKey $ _doors w
     addDoor = IM.insert drid $ Door
         { _drID = drid
-        , _drWallIDs = wlids
+        , _drWallIDs = IS.fromList wlids
         , _drStatus = DoorClosed
         , _drTrigger = cond
         , _drMech   = doorMechanism drid speed (zip3 wlids shiftedPairs pairs)

src/Dodge/Machine/Sensor.hs

@@ -11,7 +11,8 @@ import Shape
 
 lightSensor :: PSType
 lightSensor = PutMachine blue (reverse $ square wdth) defaultMachine
-    { _mcDraw = const lightSensorSPic }
+    { _mcDraw = const lightSensorSPic 
+    }
 
 lightSensorSPic :: SPic
 lightSensorSPic = ( colorSH blue $ upperPrismPoly 25 (square wdth)

src/Dodge/Render/ShapePicture.hs

@@ -39,7 +39,7 @@ worldSPic w =
     camCen = _cameraCenter w
 
 extraShapes :: World -> Shape
-extraShapes w = _foregroundShape w
+extraShapes = _foregroundShape
 
 extraPics :: World -> Picture
 extraPics w = pictures (_decorations w)

src/Dodge/Update.hs

@@ -15,6 +15,7 @@ import Dodge.Update.Camera
 import Dodge.SoundLogic
 import Dodge.Inventory
 import Dodge.WorldEvent.Sound
+import Dodge.Wall.Delete
 import Geometry
 import Geometry.ConvexPoly
 import Geometry.Vector3D
@@ -24,6 +25,7 @@ import Data.List
 import Data.Maybe
 import Data.Function
 import qualified Data.Set as S
+import qualified Data.IntSet as IS
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Data.Monoid
@@ -63,6 +65,7 @@ functionalUpdate w = case _menuLayers w of
         . updateLightSources
         . updateClouds
         . zoneClouds
+        . updateMachines
         . updateCreatures 
         . updateCreatureGroups
         . updateBlocks
@@ -86,7 +89,7 @@ splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardC
     & blocks . ix (_blID bl) . blHPs %~ tail
     & theSoundEffect cen
   where
-    wls = map (_walls w IM.!) (_blWallIDs bl)
+    wls = map (_walls w IM.!) (IS.toList $ _blWallIDs bl)
     ps = map (fst . _wlLine) wls
     cen = centroid ps
     theSoundEffect 
@@ -112,18 +115,12 @@ updateBlocks w = foldr f w $ _blocks w
 
 destroyBlock :: Block -> World -> World
 destroyBlock bl w = w
-    & walls  %~ removeIDs wlids
+    & deleteWallIDs wlids
-    & flip (foldr removeFromZone) wlids
     & blocks %~ IM.delete (_blID bl)
     & mkSoundBreakGlass pos
   where
     wlids = _blWallIDs bl
-    pos = fst . _wlLine $ _walls w IM.! head wlids
+    pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids
-    removeIDs is wls = foldr IM.delete wls is
-    removeFromZone wlid w' = over (wallsZone . znObjects . ix x . ix y) (IM.delete (_wlID wl)) w'
-      where
-        (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
-        wl = _walls w IM.! wlid -- note the use of w not w'
 
 -- | Note the explict use of record syntax. Using lens created a space leak.
 resetWorldEvents :: World -> World
@@ -158,6 +155,11 @@ updateParticles w = set particles (catMaybes ps) w'
   where 
     (w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w
 
+updateMachines :: World -> World
+updateMachines w = foldr f w (_machines w)
+  where
+    f mc = _mcUpdate mc mc
+
 -- Note that this updates the randgen
 updateCreatures :: World -> World
 updateCreatures w = appEndo f $ w 

src/Dodge/Wall/Delete.hs

@@ -0,0 +1,19 @@
+module Dodge.Wall.Delete
+    ( deleteWallIDs
+    ) where
+import Dodge.Data
+import Dodge.Zone
+import Geometry
+
+import Control.Lens
+import qualified Data.IntMap.Strict as IM
+import qualified Data.IntSet as IS
+deleteWall :: Wall -> World -> World
+deleteWall wl = (walls %~ IM.delete i)
+    . (wallsZone . znObjects . ix x . ix y %~ IM.delete i)
+  where
+    (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
+    i = _wlID wl
+
+deleteWallIDs :: IS.IntSet -> World -> World
+deleteWallIDs is w = foldr deleteWall w $ IM.restrictKeys (_walls w) is

src/Dodge/WorldEvent/DamageBlock.hs

@@ -1,10 +1,21 @@
 module Dodge.WorldEvent.DamageBlock
     ( damageBlocksBy
+    , damageWall
     ) where
 import Dodge.Data
+import Dodge.Data.DamageType
 
 import Control.Lens
 
+damageWall :: DamageType -> Wall -> World -> World
+damageWall dt wl = case _wlStructure wl of
+    MachinePart mcid -> machines . ix mcid . mcDamage %~ (dt :)
+    BlockPart blid   -> blocks   . ix blid %~ damageBlockWith dt
+    _   -> id
+
+damageBlockWith :: DamageType -> Block -> Block
+damageBlockWith _ = id
+
 damageBlocksBy :: Int -> Wall -> World -> World
 damageBlocksBy x wl = case wl ^? wlStructure . wlStBlock of
     Just blid -> blocks . ix blid . blHPs %~ reduceHeadBy x