Add forgotten files, many updates concerning turrets and shields

src/Dodge/Base.hs

@@ -144,6 +144,13 @@ insertIMInZone x y obid obj = IM.insertWith f x $ IM.singleton y $ IM.singleton
   where 
     f _ = IM.insertWith g y $ IM.singleton obid obj
     g _ = IM.insert obid obj
+deleteIMInZone 
+    :: Int      -- ^ First key
+    -> Int      -- ^ Second key
+    -> Int      -- ^ Third key
+    -> IM.IntMap (IM.IntMap (IM.IntMap a)) 
+    -> IM.IntMap (IM.IntMap (IM.IntMap a))
+deleteIMInZone x y z = ix x . ix y %~ IM.delete z
 adjustIMZone 
     :: (a -> a) -- ^ Update function
     -> Int      -- ^ First key

src/Dodge/Creature/State.hs

@@ -21,6 +21,7 @@ import Picture
 import qualified IntMapHelp as IM
 --import StrictHelp
 
+import Data.Maybe
 import Data.Function
 import Control.Lens
 --import Control.Applicative
@@ -39,10 +40,14 @@ import qualified Data.Vector.Mutable as MV
 --dummyUpdate cr _ = (Endo id, Just cr)
 
 -- | The movement is updated before the ai in order to correctly set the oldpos.
+-- This should be made more sensible: should the movement side effects apply to
+-- the creature before or after it has moved?
+-- currently invSideEffects are applied after the creature moves, to correctly
+-- update shield positions
 stateUpdate :: CRUpdate -> CRUpdate
 stateUpdate u cr w = case u (updateMovement cr) w of
     (f, maybeCr) -> 
-        ( Endo $ invSideEff cr . movementSideEff cr . deathEff . appEndo f
+        ( Endo $ invSideEff (fromMaybe cr maybeCr) . movementSideEff cr . deathEff . appEndo f
         , fmap (stepReloading . stepItemUseCooldown . doDamage . crAutoReload) $ crOrCorpse =<< maybeCr
         )
   where   

src/Dodge/Data.hs

@@ -56,6 +56,7 @@ data World = World
     , _clouds               :: [Cloud]
     , _cloudsZone           :: Zone [Cloud]
     , _props                :: IM.IntMap Prop
+    , _instantParticles     :: [Particle]
     , _particles            :: ![Particle]
     , _walls                :: !(IM.IntMap Wall)
     , _doors                :: IM.IntMap Door
@@ -397,6 +398,11 @@ data ItEffect = NoItEffect
         ,_itFloorEffect     :: Int -> World -> World 
         ,_itEffectCounter   :: Int
         }
+    | ItInvEffectID
+        {_itInvEffect       :: ItEffect -> Creature -> Int -> World -> World
+                -- the Int is the items inventory position
+        ,_itEffectID   :: Maybe Int
+        }
 data ItZoom = ItZoom 
     { _itZoomMax    :: Float
     , _itZoomMin    :: Float
@@ -568,7 +574,7 @@ data MachineType
     | Turret
         { _tuWeapon     :: Item
         , _tuTurnSpeed  :: Float
-        , _tuFiring     :: Bool
+        , _tuFireTime   :: Int
         }
 data Door = Door
     { _drID :: Int
@@ -587,7 +593,9 @@ data Wall = Wall
     , _wlSeen       :: Bool
     , _wlOpacity    :: Opacity
     , _wlPathable   :: Bool
+    , _wlWalkable   :: Bool
     , _wlFireThrough :: Bool
+    , _wlReflect    :: Bool
     , _wlDraw       :: Bool
     , _wlRotateTo   :: Bool
     , _wlStructure  :: WallStructure
@@ -602,6 +610,10 @@ data WallStructure
     | DoorPart    { _wlStDoor    :: Int }
     | MachinePart { _wlStMachine :: Int }
     | BlockPart   { _wlStBlock   :: Int }
+    | CreaturePart 
+        { _wlStCreature :: Int 
+        , _wlStDamCreature :: DamageType -> Wall -> Int -> World -> World
+        }
 -- | Strict maybe
 data Maybe' a = Just' a | Nothing'
 

src/Dodge/Data/DamageType.hs

@@ -35,4 +35,9 @@ isElectrical :: DamageType -> Bool
 isElectrical Electrical {} = True
 isElectrical _ = False
 
+isMovementDam :: DamageType -> Bool
+isMovementDam TorqueDam{} = True
+isMovementDam PushDam{} = True
+isMovementDam _ = False
+
 makeLenses ''DamageType

src/Dodge/Default/Wall.hs

@@ -13,9 +13,11 @@ defaultWall = Wall
     , _wlOpacity    = Opaque
     , _wlPathable   = False
     , _wlFireThrough = False
+    , _wlReflect = False
     , _wlDraw = True
     , _wlRotateTo = True
     , _wlStructure = StandaloneWall
+    , _wlWalkable = False
     }
 {- Indestructible see-through wall.  -}
 defaultCrystalWall :: Wall

src/Dodge/Default/World.hs

@@ -33,6 +33,7 @@ defaultWorld = World
     , _cloudsZone = Zone IM.empty
     , _itemPositions = IM.empty
     , _props = IM.empty
+    , _instantParticles = []
     , _particles = []
     , _walls = IM.empty
     , _blocks = IM.empty

src/Dodge/Item/Draw.hs

@@ -55,8 +55,8 @@ pictureWeaponOnAimItem p cr posInInv
     drawnWep        = translateSPf (1.2 * _crRad cr) 0 p
     twistWep        = translateSPf (0.5 * _crRad cr) 0 p
     oneHandWep      = translateSPf (1.5 * _crRad cr) 0 p
-    holsteredWep    = translateSPf (_crRad cr) 0 (rotateSP (sRot + 1.2) p)
-    holsteredTwoFlat    = translateSPf (_crRad cr) 0 (rotateSP (2*sRot) p)
+    holsteredWep    = translateSPf (_crRad cr) 0 (rotateSP (strideRot cr + 1.2) p)
+    holsteredTwoFlat    = translateSPf (_crRad cr) 0 (rotateSP (twoFlatHRot cr) p)
     holsteredOneHandWep = translateSPf (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) p
     handPos = case cr^? crStance . carriage of
         Just (Walking x LeftForward) -> f x * 50
@@ -65,13 +65,21 @@ pictureWeaponOnAimItem p cr posInInv
     isTwisting = _itAimStance theIt == TwoHandTwist
     isOneHand = _itAimStance theIt == OneHand
     isTwoHandFlat = _itAimStance theIt == TwoHandFlat
-    sRot = case cr ^? crStance . carriage of
+    f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen
+    sLen = _strideLength $ _crStance cr
+
+strideRot :: Creature -> Float
+strideRot cr = case cr ^? crStance . carriage of
         Just (Walking x LeftForward)  -> f x
         Just (Walking x RightForward) -> - f x
         _ -> 0
+  where
     f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen
     sLen = _strideLength $ _crStance cr
 
+twoFlatHRot :: Creature -> Float
+twoFlatHRot cr = 2*strideRot cr
+
 pictureItem
     :: SPic 
     -> Creature 

src/Dodge/Item/Equipment.hs

@@ -2,13 +2,23 @@ module Dodge.Item.Equipment
     where
 import Dodge.Data
 import Dodge.Item.Data
+import Dodge.Item.Draw
 import Dodge.Default
+import Dodge.Default.Wall
 import Dodge.Picture.Layer
+import Dodge.Item.Weapon.BatteryGuns
+import Dodge.Creature.Test
+import Dodge.Wall.Reflect
+import Dodge.Wall
+import Dodge.Creature.State.Data
 import Picture
 import Geometry
---import ShapePicture
+import ShapePicture
 import Shape
 
+import qualified Data.IntMap.Strict as IM
+import Control.Lens
+
 magShield :: Item
 magShield = defaultEquipment
     { _itIdentity = MagShield
@@ -43,6 +53,83 @@ frontArmour = defaultEquipment
     }
 flatShield :: Item
 flatShield = defaultEquipment
+    { _itEquipPict = pictureWeaponOnAim flatShieldEquipSPic
+    , _itAimStance = TwoHandFlat
+    , _itEffect = effectOnOffEquip createShieldWall removeShieldWall
+    }
+flatShieldEquipSPic :: Item -> SPic
+flatShieldEquipSPic _ = 
+    ( colorSH yellow $ upperPrismPoly 10 (rectWH 2 10)
+    , mempty
+    )
+effectOnEquip :: (Creature -> Item -> World -> World) -> ItEffect
+effectOnEquip f = ItInvEffectID
+    { _itInvEffect = g f
+    , _itEffectID = Nothing
+    }
+  where
+    g f' _ cr invid w 
+        | _crInvSel cr == invid = f' cr (_crInv (_creatures w IM.! _crID cr) IM.! invid) w
+        | otherwise = w
+
+shieldWall :: Int -> Wall
+shieldWall crid = defaultWall
+    {_wlColor = yellow
+    ,_wlOpacity = SeeAbove
+    ,_wlPathable = True
+    ,_wlWalkable = True
+    ,_wlFireThrough = True
+    ,_wlReflect = True
+    ,_wlDraw = False
+    ,_wlRotateTo = False
+    ,_wlStructure = CreaturePart crid shieldWallDamage
+    }
+
+shieldWallDamage :: DamageType -> Wall -> Int -> World -> World
+shieldWallDamage dt wl crid w = case dt of
+    Lasering {_dmFrom=df,_dmAt=da} -> 
+        w & instantParticles %~ (makeLaserAt 5 (da +.+ normalizeV (df -.- da)) (reflDirWall df da wl) :)
+    d | isMovementDam d -> w & creatures . ix crid . crState . crDamage %~ (d :)
+    _ -> w
+
+createShieldWall :: Creature -> Int -> World -> World
+createShieldWall cr invid w = case _itEffectID $ _itEffect it of
+    Nothing -> let (wlid,w') = createWall ((shieldWall crid) {_wlLine = wlline}) w
+        in w' & creatures . ix crid . crInv . ix invid . itEffect . itEffectID ?~ wlid
+    Just wid -> moveWallID wid wlline w
+  where
+    crid = _crID cr
+    it = _crInv (_creatures w IM.! crid) IM.! invid
+    wlline = (a,b)
+    crdirv = unitVectorAtAngle $ _crDir cr
+    crpos = _crPos cr
+    rad = _crRad cr + 2
+    a = crpos +.+ rad *.* crdirv -.- 10 *.* therot crdirv
+    b = crpos +.+ rad *.* crdirv +.+ 10 *.* therot crdirv
+    therot  | crIsAiming' cr = vNormal
+            | otherwise = rotateV (twoFlatHRot cr) . vNormal
+removeShieldWall :: Creature -> Int -> World -> World
+removeShieldWall cr invid w = case _itEffectID $ _itEffect it of
+    Nothing -> w
+    Just wid -> w & deleteWallID wid 
+        & creatures . ix crid . crInv . ix invid . itEffect . itEffectID .~ Nothing
+  where
+    crid = _crID cr
+    it = _crInv (_creatures w IM.! crid) IM.! invid
+
+effectOnOffEquip 
+    :: (Creature -> Int -> World -> World)     -- ^ effect when equiped
+    -> (Creature -> Int -> World -> World)     -- ^ effect when not equiped
+    -> ItEffect
+effectOnOffEquip f f' = ItInvEffectID
+    { _itInvEffect = g
+    , _itEffectID = Nothing
+    }
+  where
+    g _ cr invid w 
+        | _crInvSel cr == invid = f  cr invid w
+        | otherwise             = f' cr invid w
+
 {- | Increases speed, reduces friction, cannot only move forwards. -}
 jetPack :: Item
 jetPack = defaultEquipment

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -188,12 +188,13 @@ moveLaser phaseV pos dir w pt
     xp = pos +.+ 800 *.* unitVectorAtAngle dir
     f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either Creature Wall),[Point2])
     f seenWs x y = case find (h' seenWs) $ thingsHitExceptCrLongLine Nothing x y w of
+    --f seenWs x y = case find (h' seenWs) $ thingsHitExceptCr Nothing x y w of
         Just (p,Right wl) 
-            | _wlOpacity wl == SeeThrough -> f' p $ f (wl:seenWs) p (h x y wl p)
+            | _wlOpacity wl == SeeThrough -> addPoint 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])
-    f' p (x,ps') = (x,p:ps')
+    addPoint p (x,ps') = (x,p:ps')
     h x y wl p 
         | isEntering = p +.+ rotateV angleRef normalDist
         | otherwise = p +.+ rotateV angleRef' normalDist'

src/Dodge/Layout.hs

@@ -6,9 +6,9 @@ import Dodge.LevelGen
 import Dodge.LevelGen.Data
 import Dodge.LevelGen.StaticWalls
 import Dodge.LevelGen.Pathing
+import Dodge.Wall.Zone
 import Dodge.Placements.Spot
 import Dodge.RandomHelp
-import Dodge.Base
 import Dodge.Zone
 import Dodge.GameRoom
 import Dodge.Bounds
@@ -41,7 +41,7 @@ import Data.Maybe
 
 generateLevelFromRoomList :: State StdGen [Room] -> World -> World
 generateLevelFromRoomList gr w 
-    = updateWallZoning 
+    = initWallZoning 
     . setupWorldBounds
     . flip (foldr $ flip placeSpot) plmnts
     $ w { _walls        = wallsFromRooms rs
@@ -102,17 +102,11 @@ setupWorldBounds w = w
 polyhedrasToEdges :: [Polyhedra] -> [Point3]
 polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges
 
-updateWallZoning :: World -> World
-updateWallZoning w = set (wallsZone . znObjects) (foldl' (flip wallInZone) IM.empty (_walls w)) w
-  where
-    wallInZone wl 
-        | uncurry dist (_wlLine wl) <= 2*zoneSize = insertIMInZone x y wlid wl
-        | otherwise = flip (foldl' (flip $ \(a,b) -> insertIMInZone a b wlid wl)) ips
-      where 
-        (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
-        wlid  = _wlID wl
-        ips = map zoneOfPoint $ uncurry (divideLine zoneSize) (_wlLine wl)
-
+initWallZoning :: World -> World
+initWallZoning w = foldl' (flip insertWallInZones) (w & wallsZone . znObjects .~ IM.empty) (_walls w)
+--initWallZoning w = set (wallsZone . znObjects) (foldl' (flip wallInZone) IM.empty (_walls w)) w
+--  where
+--    wallInZone wl = flip (foldl' (flip $ \(a,b) -> insertIMInZone a b (_wlID wl) wl)) (zoneOfWall wl)
 
 makePath :: Tree Room -> [(Point2,Point2)]
 makePath = concatMap _rmPath . flatten

src/Dodge/Placements/LightSource.hs

@@ -20,9 +20,7 @@ mountLightOnShape
 mountLightOnShape shapeF mcol ls wallp lsp = ps0j (PutForeground . setCol $ shapeF wallp lsp)
     . ps0 (PutLS $ ls {_lsPos = lsp})
   where
-    setCol = case mcol of
-        Just col -> colorSH col
-        Nothing  -> id
+    setCol = maybe id colorSH mcol
 
 mountLightID :: Maybe Color -> LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
 mountLightID = mountLightOnShape f 

src/Dodge/Placements/Sensor.hs

@@ -0,0 +1,54 @@
+module Dodge.Placements.Sensor
+    ( lightSensor
+    ) where
+import Color
+import Dodge.Data
+import Dodge.LevelGen.Data
+import Dodge.Default
+import Geometry
+import ShapePicture
+import Shape
+
+import Control.Lens
+import Data.Either
+
+damageSensor 
+    :: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage
+    -> Point2 -> Float -> Placement
+damageSensor damF p r = Placement (PS p r) ( PutLS theLS)
+    $ \lsid -> jsps p r $ PutMachine yellow (reverse $ square wdth) defaultMachine
+        { _mcDraw = sensorSPic 
+        , _mcUpdate = sensorUpdate damF
+        , _mcLSs = [lsid]
+        }
+  where
+    theLS = defaultLS { _lsPos = V3 0 0 30 , _lsIntensity = 0.1 }
+
+lightSensor :: Point2 -> Float -> Placement
+lightSensor = damageSensor senseLasering
+
+senseLasering :: DamageType -> Either Int Int
+senseLasering Lasering {_dmAmount = x} = Left x
+senseLasering _ = Right 0
+
+sensorUpdate :: (DamageType -> Either Int Int) -> Machine -> World -> World
+sensorUpdate damF mc w = w & machines . ix mcid %~ upmc
+    & lightSources . ix lsid %~ upls
+  where
+    upmc = ( mcSensor %~ \x' -> min 750 (max 0 (x' - 5 + newSense)) )
+        . ( mcHP -~ sum dam )
+        . (mcDamage .~ [])
+    x = _mcSensor mc
+    mcid = _mcID mc
+    lsid = head (_mcLSs mc)
+    (senseData,dam) = partitionEithers $ map damF $ _mcDamage mc
+    newSense = sum senseData
+    ni = fromIntegral x / 500
+    upls = lsIntensity .~ V3 ni ni ni
+
+sensorSPic :: Machine -> SPic
+sensorSPic _ = ( colorSH yellow $ upperPrismPoly 25 (square wdth)
+    , mempty )
+
+wdth :: Float
+wdth = 10

src/Dodge/Placements/Turret.hs

@@ -0,0 +1,96 @@
+module Dodge.Placements.Turret
+    where
+import Color
+import Dodge.Data
+import Dodge.LevelGen.Data
+import Dodge.Default
+import Dodge.Wall.Delete
+import Dodge.WorldEvent.Explosion
+import Dodge.Item.Weapon.BatteryGuns
+import Dodge.SoundLogic.LoadSound
+import Dodge.SoundLogic
+import Dodge.Data.SoundOrigin
+import Geometry
+import ShapePicture
+import Shape
+import Dodge.Base
+import Dodge.Base.Collide
+
+import Data.List
+import Control.Lens
+import qualified Data.IntMap.Strict as IM
+
+putLasTurret :: Placement
+putLasTurret = sps0 $ PutMachine blue (reverse $ square wdth) defaultMachine
+    { _mcDraw = drawTurret
+    , _mcUpdate = updateTurret
+    , _mcType = lasTurret
+    , _mcHP = 100000
+    }
+lasTurret :: MachineType
+lasTurret = Turret
+    { _tuWeapon = lasGun
+    , _tuTurnSpeed = 0.1
+    , _tuFireTime = 0
+    }
+
+updateTurret :: Machine -> World -> World
+updateTurret mc w 
+    | _mcHP mc < 1 = w & machines %~ IM.delete mcid
+        & deleteWallIDs (_mcWallIDs mc)
+        & makeExplosionAt mcpos
+    | otherwise = w & doDamage & maybeFire & elecDamBranch
+  where
+    doDamage = machines . ix mcid %~ 
+        ( (mcDamage .~ [Electrical (min 2500 $ max 0 (elecDam - 10)) 0 0 0])
+        . (mcHP -~ dam)
+        )
+    elecDamBranch
+        | elecDam < 10 = updateFiringStatus . doTurn
+        | otherwise = id
+    maybeFire
+        | _tuFireTime (_mcType mc) > 0
+            = ( particles %~ (makeLaserAt 5 (mcpos + 15 *.* unitVectorAtAngle mcdir) mcdir :) )
+            . soundContinue (MachineSound mcid) mcpos tone440sawtoothS (Just 1)
+              
+        | otherwise = id
+    mcid = _mcID mc
+    ypos = _crPos $ you w
+    mcpos = _mcPos mc
+    mcdir = _mcDir mc
+    seesYou = hasLOSIndirect mcpos ypos w
+    (elecDams, dams) = partition isElectrical $ _mcDamage mc
+    dam = sum $ map _dmAmount dams
+    elecDam = sum $ map _dmAmount elecDams
+    doTurn  
+        | seesYou = machines . ix mcid . mcDir %~ turnTo 0.005 mcpos ypos
+        | otherwise = id
+    closeFireAngle = seesYou && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1
+    updateFiringStatus 
+        | closeFireAngle = machines . ix mcid . mcType . tuFireTime .~ 20
+        | otherwise      = machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1)
+    
+turnTo :: Float -> Point2 -> Point2 -> Float -> Float
+turnTo turnSpeed sp tp a
+    | vToTarg == V2 0 0 = a
+    | angleVV vToTarg vdir <= turnSpeed
+                                = argV vToTarg
+    | isLHS (sp +.+ vdir) sp tp = a - turnSpeed
+    | otherwise                 = a + turnSpeed
+  where
+    vdir = unitVectorAtAngle a
+    vToTarg = tp -.- sp
+
+drawTurret :: Machine -> SPic
+drawTurret mc = (rotateSH (-_mcDir mc) . colorSH blue $ upperPrismPoly 20 (square wdth)
+    , mempty -- setLayer 5 $ scale 0.5 0.5 $ text $ show $ _mcDir mc )
+    )
+    <> translateSPz 20 (_itFloorPict it it)
+  where
+    it = _tuWeapon $ _mcType mc
+
+wdth :: Float
+wdth = 10
+
+
+

src/Dodge/Update.hs

@@ -33,9 +33,7 @@ import System.Random
 
 update :: World -> World
 update = (frameClock +~ 1) . functionalUpdate
-
-{- | 
- The update step.
+{- | The update step.
 For most menus the only way to change the world is using event handling.  -}
 functionalUpdate :: World -> World
 functionalUpdate w = case _menuLayers w of
@@ -149,10 +147,16 @@ updateProjectiles w = IM.foldl' (flip $ dbArg _pjUpdate) w $ _props w
 
 {- Apply internal particle updates, delete 'Nothing's.  -}
 updateParticles :: World -> World
-updateParticles w = set particles (catMaybes ps) w'
+updateParticles w = updateInstantParticles $ set particles (catMaybes ps) w'
   where 
     (w',ps) = mapAccumR (\a b -> _ptUpdate b a b) w $ _particles w
 
+updateInstantParticles :: World -> World
+updateInstantParticles w = case _instantParticles w of
+    [] -> w
+    ps -> let (w',ps') = mapAccumR (\a b -> _ptUpdate b a b) (w {_instantParticles=[]}) ps
+        in updateInstantParticles $ w' & particles %~ (catMaybes ps' ++)
+
 updateMachines :: World -> World
 updateMachines w = foldr f w (_machines w)
   where

src/Dodge/Wall.hs

@@ -0,0 +1,8 @@
+module Dodge.Wall
+    ( module Dodge.Wall.Create
+    , module Dodge.Wall.Move
+    , module Dodge.Wall.Delete
+    ) where
+import Dodge.Wall.Create
+import Dodge.Wall.Move
+import Dodge.Wall.Delete

src/Dodge/Wall/Create.hs

@@ -0,0 +1,16 @@
+module Dodge.Wall.Create
+    where
+import Dodge.Data
+import Dodge.Wall.Zone
+
+import Control.Lens
+import qualified IntMapHelp as IM
+
+createWall :: Wall -> World -> (Int,World)
+createWall wl w = (wlid
+    , w & walls %~ IM.insert wlid newwl
+        & insertWallInZones newwl
+    )
+  where
+    newwl = wl {_wlID = wlid}
+    wlid = IM.newKey $ _walls w

src/Dodge/Wall/Damage.hs

@@ -18,6 +18,7 @@ damageWall :: DamageType -> Wall -> World -> World
 damageWall dt wl = case _wlStructure wl of
     MachinePart mcid -> machines . ix mcid . mcDamage %~ (dt :)
     BlockPart blid   -> wallEff dt wl . (blocks . ix blid %~ damageBlockWith dt)
+    CreaturePart crid f -> f dt wl crid
     _   -> wallEff dt wl
 {- | Damage effects on indestructible walls -}
 -- TODO take into account damage amount for amount of dust/sparks?

src/Dodge/Wall/Delete.hs

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

src/Dodge/Wall/Move.hs

@@ -0,0 +1,17 @@
+module Dodge.Wall.Move
+    where
+import Dodge.Data
+import Geometry
+import Dodge.Wall.Zone
+
+import Control.Lens
+moveWallID :: Int -> (Point2,Point2) -> World -> World
+moveWallID wlid wlline w = case w ^? walls . ix wlid of
+    Nothing -> w
+    Just wl -> moveWall wlid wl wlline w
+moveWall :: Int -> Wall -> (Point2,Point2) -> World -> World
+moveWall wlid wl wlline w = w & walls . ix wlid .~ newwl
+    & deleteWallFromZones wl
+    & insertWallInZones newwl
+  where
+    newwl = wl {_wlLine = wlline}

src/Dodge/Wall/Zone.hs

@@ -0,0 +1,24 @@
+module Dodge.Wall.Zone
+    where
+import Dodge.Data
+import Geometry
+import Dodge.Zone
+import Dodge.Base
+
+import Control.Lens
+import Data.Foldable
+
+zoneOfWall :: Wall -> [(Int,Int)]
+zoneOfWall wl 
+    | uncurry dist wlline <= 2*zoneSize =  [zoneOfPoint $ uncurry pHalf wlline ]
+    | otherwise = map zoneOfPoint $ uncurry (divideLine zoneSize) wlline
+  where
+    wlline = _wlLine wl
+
+insertWallInZones :: Wall -> World -> World
+insertWallInZones wl = wallsZone . znObjects
+    %~ flip (foldl' (flip $ \(a,b) -> insertIMInZone a b (_wlID wl) wl)) (zoneOfWall wl)
+
+deleteWallFromZones :: Wall -> World -> World
+deleteWallFromZones wl = wallsZone . znObjects 
+    %~ flip (foldl' (flip $ \(a,b) -> deleteIMInZone a b (_wlID wl))) (zoneOfWall wl)

src/Dodge/WallCreatureCollisions.hs

@@ -29,8 +29,8 @@ colCrWall w c
     rad = _crRad c + wallBuffer
     p1  = _crOldPos c
     p2  = _crPos c
-    ls  = IM.elems $ _wlLine <$> wallsNearPoint p2 w
-    wls = wallsNearPoint p2 w
+    ls  = IM.elems $ _wlLine <$> wls
+    wls = IM.filter (not . _wlWalkable) $ wallsNearPoint p2 w
     --wallPoints = map fst ls
     noclipIsOn = _debug_noclip $ _config w