Add IntMapHelper, locate wall cutting bug

src/Dodge/Base.hs

@@ -16,15 +16,14 @@ import Dodge.Base.Window
 import Dodge.Base.Collide
 import Geometry
 import Picture
+import qualified IntMapHelp as IM
 
 import Control.Lens
-
 --import Control.Monad.State
 import Data.List
 --import Data.Function
 import Data.Maybe
 --import Data.Bifunctor
-import qualified Data.IntMap.Strict as IM
 --import qualified Data.IntSet as IS
 --import qualified Data.Set as S
 
@@ -177,21 +176,12 @@ adjustIMZone f x y n = IM.adjust f' x
   where 
     f'  = IM.adjust f'' y
     f'' = IM.adjust f n
-{- | Find a key value one higher than any key in the map, or zero if the map is
- - empty -}
-newKey :: IM.IntMap a -> Int
-newKey = maybe 0 ((+ 1) . fst) . IM.lookupMax
 {- | Finds unused projectile key. -}
 newProjectileKey :: World -> Int
-newProjectileKey = newKey . _projectiles
+newProjectileKey = IM.newKey . _projectiles
 {- | Finds unused creature key. -}
 newCrKey :: World -> Int
-newCrKey = newKey .  _creatures
+newCrKey = IM.newKey .  _creatures
-{- | Insert an element with some new key. -}
-insertNewKey :: a -> IM.IntMap a -> IM.IntMap a
-insertNewKey x m = case IM.lookupMax m of
-    Nothing     -> IM.singleton 0 x
-    Just (k,_)  -> IM.insert (k+1) x m
 {- | TODO: determine precisely what this does. -}
 reflectPointCreature :: Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int)
 reflectPointCreature p1 p2 cr = case collidePointCirc p1 p2 (_crRad cr) (_crPos cr) of

src/Dodge/Creature.hs

@@ -28,7 +28,6 @@ import Dodge.Creature.ChaseCrit
 import Dodge.Creature.ArmourChase
 import Dodge.Data
 import Dodge.Default
-import Dodge.Base
 import Dodge.Item.Weapon
 import Dodge.Item.Equipment
 import Dodge.Item.Consumable
@@ -43,6 +42,7 @@ import Dodge.Creature.Rationality
 import Dodge.Picture.Layer
 import Picture
 --import Geometry
+import qualified IntMapHelp as IM
 
 --import Data.List
 --import Data.Char
@@ -52,7 +52,6 @@ import Control.Lens
 --import Control.Monad.Reader
 --import System.Random
 --import qualified Data.Set as S
-import qualified Data.IntMap.Strict as IM
 --import qualified Data.Map as M
 
 spawnerCrit :: Creature
@@ -133,7 +132,7 @@ multGunCrit = defaultCreature
 addArmour :: Creature -> Creature
 addArmour = over crInv insarmour
   where 
-    insarmour xs = IM.insert (newKey xs) frontArmour xs
+    insarmour xs = IM.insert (IM.newKey xs) frontArmour xs
 {- | The creature you control.
 ID 0.  -}
 startCr :: Creature
@@ -156,7 +155,8 @@ startCr = defaultCreature
 startInventory :: IM.IntMap Item
 startInventory = IM.fromList (zip [0..20] 
     (
-    [bezierGun
+    [blinkGun
+    ,bezierGun
     ,multGun
     ,hvAutoGun
     ,remoteLauncher

src/Dodge/Creature/Action.hs

@@ -19,6 +19,7 @@ import Dodge.Inventory
 --import Dodge.LightSources
 import Geometry
 import Picture
+import qualified IntMapHelp as IM
 
 import Control.Lens
 --import Control.Monad
@@ -26,7 +27,6 @@ import Control.Lens
 import Data.Maybe
 --import Data.List
 import System.Random
-import qualified Data.IntMap.Strict as IM
 --import qualified Data.Map as M
 
 startReloadingWeapon 
@@ -107,7 +107,7 @@ copyItemToFloor cr i w = case _crInv cr IM.! i of
         updateLocation w' = case it ^? itID of
             Just (Just i')  -> w' & itemPositions . ix i' .~ OnFloor flid
             _ -> w'
-        flid = newKey $ _floorItems w
+        flid = IM.newKey $ _floorItems w
         theflit = FlIt 
             {_flIt = it
             ,_flItPos = offset +.+ _crPos cr

src/Dodge/Creature/ArmourChase.hs

@@ -22,16 +22,17 @@ armourChaseCrit = defaultCreature
     { _crUpdate = stateUpdate $ impulsiveAIR $ 
         doStrategyActionsR >=>
         performActionsR >=>
-        overrideMeleeCloseTargetR >=>
         chaseTargetR targetYouLOS >=>
         basicPerceptionUpdateR [0] >=>
         targetYouWhenCognizantR  >=>
-        return . (crMeleeCooldown . _Just %~ (max 0 . subtract 1))
+        overrideMeleeCloseTargetR >=>
+        return . (crMeleeCooldown . _Just %~ max 0 . subtract 1)
     , _crHP = 300
     , _crPict = basicCrPict green
     , _crInv = IM.fromList 
         [(0,frontArmour)
         ,(1,medkit 200)
         ]
+    , _crMeleeCooldown = Just 0
     , _crGroup = ShieldGroup
     }

src/Dodge/Creature/ChaseCrit.hs

@@ -41,7 +41,7 @@ chaseCrit = defaultCreature
         chaseTargetR targetYouLOS >=>
         basicPerceptionUpdateR [0] >=>
         targetYouWhenCognizantR >=>
-        return . (crMeleeCooldown . _Just %~ (max 0 . subtract 1))
+        return . (crMeleeCooldown . _Just %~ max 0 . subtract 1)
     , _crHP = 300
     , _crPict = basicCrPict green
     , _crInv = IM.fromList [(0,medkit 200)]

src/Dodge/Creature/ImpulseRat.hs

@@ -20,19 +20,6 @@ chaseTarget targFunc w cr = case targFunc cr w of
     Nothing -> cr
     Just crTarg -> cr & crActionPlan . crImpulse .~ chaseTarg cr crTarg
 
-
-overrideMeleeCloseTarget :: World -> Creature -> Creature
-overrideMeleeCloseTarget _ cr = case _crTarget cr of
-    Nothing -> cr
-    Just tcr
-        | _crMeleeCooldown cr == Just 0
-            && dist (_crPos tcr) cpos < _crRad cr + _crRad tcr + 5 
-            && abs (_crDir cr - argV (_crPos tcr -.- cpos)) < pi/4
-            -> cr & crActionPlan . crAction .~ [DoImpulses [Melee (_crID tcr)]]
-        | otherwise -> cr
-  where
-    cpos = _crPos cr
-
 meleeHeadingMove
     :: Float -- ^ max turn speed
     -> Float -- ^ min turn speed

src/Dodge/Creature/Inanimate.hs

@@ -6,7 +6,6 @@ module Dodge.Creature.Inanimate
 import Dodge.Data
 --import Dodge.Creature.Stance.Data
 import Dodge.Creature.State.Data
-import Dodge.Base
 import Dodge.Picture.Layer
 import Dodge.Default
 import Dodge.Creature.State
@@ -15,8 +14,8 @@ import Dodge.WorldEvent.Flash
 import Dodge.WorldEvent.Sound
 import Dodge.Creature.Update hiding (CRUpdate)
 import Picture
+import qualified IntMapHelp as IM
 
-import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
 defaultInanimate :: Creature
@@ -34,7 +33,7 @@ lamp = defaultInanimate
 initialiseLamp :: CRUpdate
 initialiseLamp w (f,g) cr = ( (addLS . f , g), Just $ cr & crUpdate .~ updateLamp i)
   where
-    i = newKey $ _lightSources $ f w -- to give different lights different keys
+    i = IM.newKey $ _lightSources $ f w -- to give different lights different keys
     addLS = over lightSources (IM.insert i (lightAt (_crPos cr) i))
 
 updateLamp :: Int -> CRUpdate

src/Dodge/Creature/ReaderUpdate.hs

@@ -22,14 +22,15 @@ tryMeleeAttack cr tcr
     | _crMeleeCooldown cr == Just 0
         && dist (_crPos tcr) cpos < _crRad cr + _crRad tcr + 5 
         && abs (_crDir cr - argV (_crPos tcr -.- cpos)) < pi/4
-        = cr & crActionPlan . crStrategy .~ StrategyActions MeleeStrike meleeActions
+        -- = cr & crActionPlan . crStrategy .~ StrategyActions MeleeStrike meleeActions
+        = cr & crActionPlan . crImpulse .~ [Melee $ _crID tcr]
     | otherwise = cr
   where
     cpos = _crPos cr
-    meleeActions = 
+    --meleeActions = 
-        [DoImpulses [Melee (_crID tcr)]
+    --    [DoImpulses [Melee (_crID tcr)]
-        `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
+    --    `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
-        ]
+    --    ]
 
 chaseTargetR
     :: (Creature -> World -> Maybe Creature)    -- ^ Function for determining target

src/Dodge/Creature/State.hs

@@ -11,6 +11,7 @@ import Dodge.WorldEvent
 import Dodge.Creature.Action
 import Geometry
 import Picture
+import qualified IntMapHelp as IM
 
 import Data.List
 --import Data.Char
@@ -24,7 +25,6 @@ import Control.Monad.State
 --import qualified SDL.Mixer as Mix
 import System.Random
 --import qualified Data.Set as S
-import qualified Data.IntMap.Strict as IM
 --import qualified Data.Map as M
   
 type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
@@ -53,7 +53,7 @@ stateUpdate u w (f,g) cr =
             . over decorations addCorpse 
             . dropByState cr
     --crBeforeDeath = colCrWall w cr
-    addCorpse = insertNewKey 
+    addCorpse = IM.insertNewKey 
         $ uncurry translate (_crOldPos cr) 
         $ rotate (_crDir cr)
         (_crCorpse cr)
@@ -210,9 +210,8 @@ updateExpBarrel _ (f,g) cr
     --perforate (Piercing amount sp int ep) cr = over (crState . crSpState . piercedPoints)
     --                                                  ((:) $ int -.- _crPos cr) cr
     --perforate _ cr = cr
-    applyFuseDamage cr' = over crHP (subtract $ length (_piercedPoints 
+    applyFuseDamage cr' = cr' & crHP %~ 
-                                                       $ _crSpState $ _crState cr')) 
+        subtract (length . _piercedPoints . _crSpState $ _crState cr')
-                                   cr'
     hiss | null poss = id
          | otherwise  = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1
     stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1)

src/Dodge/Creature/SwarmCrit.hs

@@ -32,7 +32,7 @@ swarmCrit :: Creature
 swarmCrit = defaultCreature
     { _crUpdate = stateUpdate $ impulsiveAIR $
         flockToPointUsing (encircleDistP (100)) (meleeHeadingMove 0.1 0.1 (pi/4) 3.9)
-        >=> return . (crMeleeCooldown . _Just %~ (max 0 . subtract 1))
+        >=> return . (crMeleeCooldown . _Just %~ max 0 . subtract 1)
         >=> basicPerceptionUpdateR [0]
         >=> doStrategyActionsR
         >=> targetYouWhenCognizantR

src/Dodge/Debug.hs

@@ -1,13 +1,12 @@
 module Dodge.Debug where
 import Dodge.Data
-import Dodge.Base
 import Dodge.Picture
 import Dodge.Picture.Layer
 --import Geometry.Data
 import Picture
+import qualified IntMapHelp as IM
 
 import Control.Lens
-import qualified Data.IntMap.Strict as IM
 
 drawCircleAtFor :: Point2 -> Int -> World -> World
 drawCircleAtFor p t w = w & projectiles %~ 
@@ -20,7 +19,7 @@ drawCircleAtFor p t w = w & projectiles %~
         , _pjUpdate = pjTimer t k
         }
   where
-    k = newKey $ _projectiles w
+    k = IM.newKey $ _projectiles w
 drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World
 drawCircleAtForCol p t col w = w & projectiles %~
     IM.insert k Projectile 
@@ -32,7 +31,7 @@ drawCircleAtForCol p t col w = w & projectiles %~
         , _pjUpdate = pjTimer t k
         }
   where
-    k = newKey $ _projectiles w
+    k = IM.newKey $ _projectiles w
 drawLineForCol :: [Point2] -> Int -> Color -> World -> World
 drawLineForCol ps t col w = w & projectiles %~
     IM.insert k Projectile 
@@ -44,8 +43,9 @@ drawLineForCol ps t col w = w & projectiles %~
         , _pjUpdate = pjTimer t k
         }
   where
-    k = newKey $ _projectiles w
+    k = IM.newKey $ _projectiles w
 
 pjTimer :: Int -> Int -> World -> World
 pjTimer 0    i = projectiles %~ IM.delete i
 pjTimer time i = projectiles . ix i . pjUpdate .~ pjTimer (time - 1) i
+

src/Dodge/Debug/LinkDecoration.hs

@@ -0,0 +1,34 @@
+module Dodge.Debug.LinkDecoration
+    ( addRoomLinkDecorations
+    , addRoomPolyDecorations
+    ) where
+import Dodge.Data
+--import Dodge.Base
+import Dodge.Room.Data
+import Dodge.Picture.Layer
+import Picture
+import qualified IntMapHelp as IM
+import Geometry.Vector
+
+import Control.Lens
+
+addRoomPolyDecorations :: [Room] -> World -> World
+addRoomPolyDecorations rms w = w & decorations %~ 
+    IM.insertWithNewKeys (map roomPolyDecorations rms)
+
+addRoomLinkDecorations :: [Room] -> World -> World
+addRoomLinkDecorations rms w = w & decorations %~ 
+    IM.insertWithNewKeys (map roomLinkDecorations rms)
+
+roomLinkDecorations :: Room -> Picture
+roomLinkDecorations rm = pictures . map linkDecoration $ _rmLinks rm 
+
+linkDecoration :: (Point2,Float) -> Picture
+linkDecoration (p,a) = setLayer 1 . onLayer DebugLayer . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi/2)]
+
+roomPolyDecorations :: Room -> Picture
+roomPolyDecorations rm = pictures . map polyWireFrame $ _rmPolys rm
+
+polyWireFrame :: [Point2] -> Picture
+polyWireFrame (x:xs) = setLayer 1 . onLayer DebugLayer . color green $ line $ (x:xs) ++ [x]
+polyWireFrame _ = undefined

src/Dodge/Event/Menu.hs

@@ -69,7 +69,7 @@ handlePressedKeyInMenu mState scode w = case mState of
         & menuLayers .~ [WaitMessage "GENERATING..." 1]
         & worldEvents .~ const aNewGame
     aNewGame :: World
-    aNewGame = updateFramebufferSize $ generateFromList levx $ initialWorld 
+    aNewGame = updateFramebufferSize $ generateLevelFromRoomList levx $ initialWorld 
         & randGen .~ _randGen w
         & config .~ _config w
 

src/Dodge/Floor.hs

@@ -75,7 +75,7 @@ roomTreex = do
                     ,[DoorNumAno 0,AirlockAno]] 
                     ]
             ,[FirstWeapon]
-            ,[Corridor]
+            ,[CorridorDebug]
             ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]
             ,[Corridor]
             ,[OrAno 
@@ -93,7 +93,5 @@ roomTreex = do
     shiftExpandTree . expandTreeBy id <$> mapM annoToRoomTree t
 
 --swarmTestRoom :: 
-
-
 levx :: RandomGen g => State g [Room]
 levx = untilJust roomTreex

src/Dodge/Initialisation.hs

@@ -20,7 +20,7 @@ firstWorld = do
 --    i <- randomRIO (0,5000)
     let i = 2
     putStrLn $ "Seed for level generation: " ++ show ( i :: Int)
-    return $ generateFromList levx $ initialWorld {_randGen = mkStdGen i}
+    return $ generateLevelFromRoomList levx $ initialWorld {_randGen = mkStdGen i}
 
 initialWorld :: World
 initialWorld = defaultWorld

src/Dodge/Item/Weapon.hs

@@ -24,6 +24,7 @@ import Dodge.Item.Attachment.Data
 import Dodge.Item.Attachment
 import Geometry
 import Picture
+import qualified IntMapHelp as IM
 
 --import Data.List
 --import Data.Char
@@ -38,7 +39,6 @@ import Control.Monad.State
 import qualified SDL
 import System.Random
 import qualified Data.Set as S
-import qualified Data.IntMap.Strict as IM
 --import qualified Data.Map as M
 
 pistol
@@ -930,7 +930,7 @@ fireRemoteLauncher cid w = setLocation
     $ soundOnce (fromIntegral launcherSound)
     $ over projectiles remRocket w
   where
-    i = newKey $ _projectiles w
+    i = IM.newKey $ _projectiles w
     cr = _creatures w IM.! cid
     dir = _crDir cr
     pos = _crPos cr +.+ rotateV dir (_crRad cr + 1,0)
@@ -943,7 +943,7 @@ fireRemoteLauncher cid w = setLocation
         , _pjUpdate = moveRemoteShell 50 i cid itid dir
         }
     j = _crInvSel $ _creatures w IM.! cid
-    newitid = newKey $ _itemPositions w
+    newitid = IM.newKey $ _itemPositions w
     maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just
     resetFire = set (creatures . ix cid . crInv . ix j . wpFire) 
         $ hammerCheck $ explodeRemoteRocket itid i
@@ -1083,7 +1083,7 @@ throwRemoteBomb n w = setLocation $ removePict $ resetFire
                       Nothing -> w' & creatures . ix n . crInv . ix j . itID ?~ newitid
                                     & itemPositions %~ IM.insert newitid (InInv n j)
                       _ -> w'
-    newitid = newKey $ _itemPositions w
+    newitid = IM.newKey $ _itemPositions w
     itid = fromMaybe newitid maybeitid
 
 explodeRemoteBomb :: Int -> Int -> Int -> World -> World
@@ -1223,7 +1223,7 @@ spawnCrNextTo
     -> World
 spawnCrNextTo cr i w = w & creatures %~ IM.insert k newCr
   where
-    k = newKey $ _creatures w
+    k = IM.newKey $ _creatures w
     sCr = _creatures w IM.! i
     newCr = cr
         & crID  .~ k

src/Dodge/Layout.hs

@@ -12,6 +12,8 @@ import Dodge.Room.Data
 import Dodge.Default
 import Geometry
 import Dodge.Room.Link
+import qualified IntMapHelp as IM
+import Dodge.Debug.LinkDecoration
 
 import Control.Monad.State
 import Control.Lens
@@ -21,11 +23,12 @@ import System.Random
 import Data.Tree
 import Data.Graph.Inductive.Graph (labNodes)
 import qualified Data.Map as M
-import qualified Data.IntMap.Strict as IM
 
-generateFromList :: State StdGen [Room] -> World -> World
+generateLevelFromRoomList :: State StdGen [Room] -> World -> World
-generateFromList gr w = updateWallZoning 
+generateLevelFromRoomList gr w = updateWallZoning 
     . placeSpots plmnts
+    . addRoomPolyDecorations rs
+    . addRoomLinkDecorations rs
     $ w { _walls = wallsFromRooms rs
         }
   where
@@ -95,7 +98,7 @@ divideWall wl
 divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
 divideWallIn wl wls = 
     let (wl':newWls) = divideWall wl
-        k = newKey wls
+        k = IM.newKey wls
         newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
     in  foldr (\w -> IM.insert (_wlID w) w) wls (wl':newWls')
 

src/Dodge/Layout/Tree/Annotate.hs

@@ -27,6 +27,7 @@ data Annotation g
     = Lock Int
     | Key  Int
     | Corridor
+    | CorridorDebug
     | DoorAno
     | SwitchDoorAno
     | DoorNumAno Int
@@ -71,6 +72,7 @@ annoToRoomTree [OrAno as] = do
     a <- takeOne as
     annoToRoomTree a
 annoToRoomTree [Corridor] = pure . Right <$> randomiseOutLinks corridor
+annoToRoomTree [CorridorDebug] = pure . Right <$> randomiseOutLinks corridorDebug
 annoToRoomTree [DoorAno] = roomThenCorridor door
 annoToRoomTree [DoorNumAno i,AirlockAno] = airlock i >>=  roomThenCorridor
 annoToRoomTree [FirstWeapon] = do

src/Dodge/LevelGen.hs

@@ -9,7 +9,6 @@ module Dodge.LevelGen
     , makeSwitch
     ) where
 import Dodge.Data
-import Dodge.Base
 --import Dodge.Room.Data
 import Dodge.LevelGen.Block
 import Dodge.LevelGen.LineBlock
@@ -21,6 +20,7 @@ import Dodge.LevelGen.Switch
 import Dodge.LevelGen.Data
 import Geometry
 import Picture
+import qualified IntMapHelp as IM
 
 --import System.Random
 import Control.Monad.State
@@ -29,7 +29,6 @@ import Control.Lens
 import Data.List.Extra
 --import Data.Function
 --import Data.Maybe
-import qualified Data.IntMap.Strict as IM
 --import qualified Data.Set as S
 --import qualified Data.Map as M
 
@@ -128,9 +127,9 @@ addWalls qs wl wls = foldr (addPane wl) wls pairs
     pairs = zip (ps ++ [p]) (p:ps)
 
 addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
-addPane wl (p0,p1) wls = IM.insert (newKey wls) (wl
+addPane wl (p0,p1) wls = IM.insert (IM.newKey wls) (wl
     { _wlLine = (p0,p1)
-    , _wlID = newKey wls
+    , _wlID = IM.newKey wls
     })
     wls
 
@@ -142,7 +141,7 @@ placeBt
     -> World
 placeBt bt p rot = over buttons addBT
   where 
-    addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts
+    addBT bts = IM.insert (IM.newKey bts) (bt {_btPos = p, _btRot = rot, _btID = IM.newKey bts}) bts
 {- Creates a floor item at a given point.
 Assigns an id correctly.  -}
 placeFlIt
@@ -152,11 +151,11 @@ placeFlIt
     -> World
     -> World
 placeFlIt itm p rot = floorItems %~ 
-    \ fis -> IM.insert (newKey fis) 
+    \ fis -> IM.insert (IM.newKey fis) 
         (FlIt
             { _flItPos = p
             , _flItRot = rot
-            , _flItID = newKey fis
+            , _flItID = IM.newKey fis
             , _flIt = itm
             }
         ) fis
@@ -169,30 +168,30 @@ placePressPlate
     -> World
 placePressPlate pp p rot = over pressPlates addPP
   where 
-    addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
+    addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
 
 placeUpdateCr :: Creature -> Point2 -> Float -> World -> (World, PSType)
 placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
   where 
-    cid = newKey (_creatures w)
+    cid = IM.newKey (_creatures w)
     cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} 
 
 placeCr :: Creature -> Point2 -> Float -> World -> World
 placeCr crF p rot = over creatures addCr
   where 
     addCr crs = IM.insert 
-        (newKey crs) 
+        (IM.newKey crs) 
-        (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs}) 
+        (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = IM.newKey crs}) 
         crs
 
 placeLS :: LightSource -> Picture -> Point2 -> Float -> World -> World
 placeLS ls dec p rot w = over lightSources addLS $ over decorations addDec w
   where 
     addLS lss = IM.insert 
-        (newKey lss) 
+        (IM.newKey lss) 
-        (ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss}) 
+        (ls {_lsPos = p,_lsDir = rot,_lsID = IM.newKey lss}) 
         lss
     addDec decs = IM.insert 
-        (newKey decs) 
+        (IM.newKey decs) 
         (uncurry translate p $ rotate (negate rot) dec)
         decs

src/Dodge/LevelGen/AutoDoor.hs

@@ -12,10 +12,10 @@ import Dodge.Creature.Property
 import Geometry
 import Picture
 import qualified DoubleStack as DS
+import qualified IntMapHelp as IM
 
 --import Data.List
 --import Data.Maybe
-import qualified Data.IntMap.Strict as IM
 import Control.Lens
 --import Control.DeepSeq (deepseq)
 
@@ -33,7 +33,7 @@ autoDoorAt
     -> IM.IntMap Wall
 autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
   where 
-    i = newKey wls
+    i = IM.newKey wls
     is = [i..]
 
 mkAutoDoor 

src/Dodge/LevelGen/Block.hs

@@ -7,13 +7,13 @@ import Dodge.WorldEvent.Sound
 import Dodge.LevelGen.Pathing
 import Geometry
 import Picture.Data
+import qualified IntMapHelp as IM
 
 import Control.Lens
 import Control.Monad.State
 import Data.List
 import Data.Maybe
 import Data.Function
-import qualified Data.IntMap.Strict as IM
 import System.Random
 
 updateBlocks :: World -> World
@@ -103,7 +103,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w
         & walls     %~ IM.union panes
   where 
     lns = zip (p:ps) (ps ++ [p])
-    i = newKey $ _walls w
+    i = IM.newKey $ _walls w
     is = [i.. i + length lns-1]
     panes = IM.fromList $ zip is $ zipWith 
         (\j (a,b) -> Block 

src/Dodge/LevelGen/LineBlock.hs

@@ -8,9 +8,9 @@ import Dodge.Base
 import Dodge.LevelGen.Pathing
 --import Picture
 import Geometry
+import qualified IntMapHelp as IM
 
 import Control.Lens
-import qualified Data.IntMap as IM
 
 putLineBlock 
     :: Wall     -- ^ Base pane
@@ -37,7 +37,7 @@ putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr i
         ]
     cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
     linesAt p = makeLoopPairs $ cornersAt p
-    k = newKey $ _walls w
+    k = IM.newKey $ _walls w
     ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
     visibilityAt i 
         | i == 0             = [ True,True,False,True]

src/Dodge/LevelGen/StaticWalls.hs

@@ -38,24 +38,29 @@ removeInverseWalls ((a,b):ps)
 removeInverseWalls ps = ps
 -- | Cut out a polygon from a set of walls, and check for errors in the
 -- created walls.
--- If created walls are not consistent, rotate and expand poly and retry.
+-- If created walls are not consistent, retry, rotating and expanding poly.
 cutWalls :: [Point2] -> [WallP] -> [WallP]
 cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
     [] -> newWalls
---    _  -> cutWalls (expandPolyBy 100 ps) wls
+    _  -> cutWallsRetry 0 ps wls
---    _  -> cutWalls (expandPolyBy 0.01 ps) wls
+--    _  -> wls
-    _  -> cutWalls (map (rotateV 0.001) $ expandPolyBy 0.01 ps) wls
+--    _  -> error $ show ps 
   where
-    newWalls = cutWalls' ps wls
+    newWalls = cutPoly ps wls
--- | As 'cutWalls', but rotate in the other direction.
+cutWallsRetry :: Int -> [Point2] -> [WallP] -> [WallP]
-cutWallsL :: [Point2] -> [WallP] -> [WallP]
+--cutWallsRetry 200 ps wls = error $ show ps ++ show wls
-cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
+cutWallsRetry i ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
     [] -> newWalls
---    _  -> cutWalls (expandPolyBy 100 ps) wls
+    _  -> cutWallsRetry (i+1) ps wls
---    _  -> cutWalls (expandPolyBy 0.01 ps) wls
+--    _  -> wls
-    _  -> cutWalls (map (rotateV (-0.001)) $ expandPolyBy 0.01 ps) wls
+--    _  -> error $ show ps 
   where
-    newWalls = cutWalls' ps wls
+    newWalls = cutPoly ps' wls
+    --ps' = map (rotateV a) $ expandPolyBy 0.1 ps
+    ps' = map (rotateV a) $ expandPolyBy x ps
+    x = fromIntegral i / 100
+    a | even i    = 0.001
+      | otherwise = negate 0.001
 -- | Cut out a polygon from a set of walls, and check for errors in the
 -- created walls.
 -- Give error if created walls are not consistent.
@@ -72,7 +77,7 @@ cutWalls'' ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
         ++ "\nWalls after cut:\n"
         ++ unlines (map show newWalls)
   where
-    newWalls = cutWalls' ps wls
+    newWalls = cutPoly ps wls
     errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
 -- | Given a specific wall and list of walls, checks that the number of walls leaving the
 -- second point is the same as the number of walls entering the second point of
@@ -109,10 +114,10 @@ checkWallLeft (x,y) wls
 -- 5. remove any walls that ended up zero length after fusing
 -- 6. remove any duplicate walls
 -- Unclear behaviour if a line in the polygon is colinear with a wall.
-cutWalls' :: [Point2] -> [WallP] -> [WallP]
+cutPoly :: [Point2] -> [WallP] -> [WallP]
-cutWalls' qs wls = 
+cutPoly qs wls = 
     nub
-    . filter (not.wallIsZeroLength) 
+    . filter (not . wallIsZeroLength) 
     . fuseWallsWith zs
     . addPolyWalls rs  
 --    . removeWallsInPolygon ps 
@@ -131,6 +136,7 @@ expandPolyBy x ps = map f ps
   where
     cp = 1/fromIntegral (length ps) *.* foldr (+.+) (0,0) ps
     f p = p +.+ x *.* (p -.- cp)
+    --f p = p +.+ x *.* normalizeV (p -.- cp)
 -- | Given a polygon expressed as a list of points and a collection of walls,
 -- returns: 
 -- fst: points of the polygon's intersection with walls
@@ -223,3 +229,29 @@ removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
 removeWallsInPolygon ps = filter (not . cond)
   where 
     cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
+
+brokenWalls :: [(Point2,Point2)]
+brokenWalls = 
+    [((330.12192,3032.2456),(190.52365,2995.8352)),((190.52365,2995.8352),(203.94716,2945.9377)),((214.33855,2907.311),(230.12193,2859.0405)),((230.12193,2859.0405),(366.7245,2895.643)),((366.7245,2895.643),(330.12192,3032.2456)),((366.7245,2895.643),(230.12193,2859.0405)),((230.12193,2859.0405),(266.7245,2722.438)),((266.7245,2722.438),(403.32703,2759.0405)),((403.32703,2759.0405),(503.32703,2932.2456)),((466.72446,3068.8481),(330.12192,3032.2456)),((330.12192,3032.2456),(366.7245,2895.643)),((503.32703,2932.2456),(466.72446,3068.8481)),((203.94716,2945.9377),(145.99155,2930.4084)),((156.38292,2891.7817),(214.33855,2907.311)),((107.47222,2920.979),(34.06077,2901.2295)),((34.06077,2901.2295),(52.571453,2832.4224)),((70.17772,2796.55),(174.45558,2824.6025)),((174.45558,2824.6025),(156.38292,2891.7817)),((100.76944,2955.4202),(107.47222,2920.979)),((145.99155,2930.4084),(140.79587,2949.722)),((52.571453,2832.4224),(35.882084,2827.9504)),((31.745949,2785.4312),(70.17772,2796.55)),((88.14497,3002.5354),(100.76944,2955.4202)),((140.79587,2949.722),(120.21855,3027.0303)),((35.882084,2827.9504),(-22.07344,2812.4214)),((-31.039248,2768.608),(31.745949,2785.4312)),((-261.32483,3408.5737),(-303.9881,3451.237)),((-303.9881,3451.237),(-332.27234,3422.9526)),((-332.27234,3422.9526),(-289.84595,3380.5264)),((-261.56174,3352.242),(88.14497,3002.5354)),((120.21855,3027.0303),(-233.27742,3380.5264)),((-289.84595,3380.5264),(-332.2724,3338.0999)),((-332.2724,3338.0999),(-303.9881,3309.8157)),((-303.9881,3309.8157),(-261.56174,3352.242)),((-22.07344,2812.4214),(-89.68823,2794.304)),((-79.335526,2755.667),(-31.039248,2768.608)),((-210.16953,3456.4133),(-261.32483,3408.5737)),((-233.27742,3380.5264),(-194.64026,3419.1633)),((-128.32533,2783.9514),(-200.79468,3054.4106)),((-200.79468,3054.4106),(-780.35016,2899.1191)),((-780.35016,2899.1191),(-625.05865,2319.5635)),((-625.05865,2319.5635),(-45.503174,2474.855)),((-45.503174,2474.855),(-117.97253,2745.3142)),((-89.68823,2794.304),(-128.32533,2783.9514)),((-117.97253,2745.3142),(-79.335526,2755.667)),((-178.49438,3590.2566),(-241.50847,3573.372)),((-241.50847,3573.372),(-210.16953,3456.4133)),((-194.64026,3419.1633),(-136.80266,3434.6611)),((-98.165634,3445.014),(-139.85736,3600.6094)),((-92.98925,3425.6953),(-98.165634,3445.014)),((-136.80266,3434.6611),(-127.74397,3400.8535)),((-187.553,3624.064),(-178.49438,3590.2566)),((-139.85736,3600.6094),(-148.91603,3634.4167)),((-127.74397,3400.8535),(-111.20285,3339.121)),((-78.55679,3371.8325),(-92.98925,3425.6953)),((-349.5008,4383.0093),(-388.13782,4372.6563)),((-388.13782,4372.6563),(-485.18823,3653.0168)),((-485.18823,3653.0168),(-477.42368,3624.039)),((-477.42368,3624.039),(-206.96445,3696.5085)),((-168.32744,3706.861),(102.131805,3779.3306)),((102.131805,3779.3306),(94.36725,3808.308)),((94.36725,3808.308),(-349.5008,4383.0093)),((-206.96445,3696.5085),(-187.553,3624.064)),((-148.91603,3634.4167),(-168.32744,3706.861)),((299.35522,3346.2668),(97.2383,3547.9797)),((97.2383,3547.9797),(-78.55679,3371.8325)),((-111.20285,3339.121),(116.74672,3110.6904)),((116.74672,3110.6904),(320.08704,3314.438)),((352.084,3395.578),(299.35522,3346.2668)),((320.08704,3314.438),(367.6133,3358.328)),((495.06226,3666.979),(293.8115,3613.054)),((293.8115,3613.054),(352.084,3395.578)),((367.6133,3358.328),(563.6875,3410.866)),((563.6875,3410.866),(495.06226,3666.979))]
+
+intersectingBrokenWalls :: [(Point2,Point2)]
+intersectingBrokenWalls = filter (\(a,b) -> test a b) brokenWalls
+  where
+    polyPairs = zip brokenPoly (tail brokenPoly ++ [head brokenPoly])
+    test a b = any (isJust . uncurry (myIntersectSegSeg a b)) polyPairs
+
+brokenPoly :: [Point2]
+brokenPoly = [(434.66675,2833.3225),(503.9488,2793.3225),(523.9488,2827.9636),(454.66675,2867.9636)]
+
+iBWall :: (Point2,Point2)
+iBWall = ((403.32703,2759.0405),(503.32703,2932.2456))
+
+expandToSquare :: (Point2,Point2) -> [(Point2,Point2)]
+expandToSquare (a,b) = [(a,b),(b,c),(c,d),(d,a)]
+  where
+    v = a -.- b
+    c = b +.+ vNormal v
+    d = a +.+ vNormal v
+
+minWalls :: [(Point2,Point2)]
+minWalls = expandToSquare iBWall

src/Dodge/LevelGen/SwarmPlacement.hs

@@ -3,14 +3,13 @@ module Dodge.LevelGen.SwarmPlacement
     )
     where
 import Dodge.Data
-import Dodge.Base
 import Dodge.LevelGen.Data
 import Dodge.Creature.State.Data
 import Geometry
+import qualified IntMapHelp as IM
 
 import Data.List
 import qualified Data.IntSet as IS
-import qualified Data.IntMap as IM
 import Control.Lens
 
 swarmPS :: Int -> Point2 -> Float -> Creature -> Placement
@@ -26,7 +25,7 @@ setSwarm w ps = updateCrs w' & creatureGroups %~ IM.insert gid theGroupParams
     (w', crs) = mapAccumR updateCrit w ps
     is = IS.fromList $ map _crID crs
     cpos = centroid $ map _crPos crs
-    gid = newKey (_creatureGroups w')
+    gid = IM.newKey (_creatureGroups w')
     theGroupParams = CrGroupParams
         { _crGroupParamID = gid
         , _crGroupIDs = is
@@ -52,5 +51,5 @@ updateCrit w pl = (w & creatures %~ IM.insert cid cr
     p = _psPos $ _placementSpot pl
     rot = _psRot $ _placementSpot pl
     scr = _unPutCrit $ _psType $ _placementSpot pl
-    cid = newKey (_creatures w)
+    cid = IM.newKey (_creatures w)
     cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} 

src/Dodge/LevelGen/TriggerDoor.hs

@@ -9,10 +9,10 @@ import Dodge.LevelGen.Pathing
 import Picture
 import Geometry
 import qualified DoubleStack as DS
+import qualified IntMapHelp as IM
 
 import Data.List
 import Data.Maybe
-import qualified Data.IntMap.Strict as IM
 import Control.Lens
 import Data.Graph.Inductive hiding ((&))
 
@@ -24,7 +24,7 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
     $ set pathGraph' newGraphPairs
     $ putDoubleDoor c cond a b w
   where 
-    bid = newKey $ _buttons w
+    bid = IM.newKey $ _buttons w
     cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
     bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
     (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b)) 
@@ -42,7 +42,7 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
     $ set pathGraph' newGraphPairs
     $ putDoubleDoor c cond a b w
   where 
-    bid = newKey $ _buttons w
+    bid = IM.newKey $ _buttons w
     cond w' = BtOn == _btState (_buttons w' IM.! bid)
     bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
     (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b)) 
@@ -67,14 +67,14 @@ putDoor c cond pss = over walls triggerDoor
   where
     triggerDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond pss is
       where
-        is = [newKey wls..]
+        is = [IM.newKey wls..]
 
 putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
 putDoubleDoor c cond a b = over walls triggerDoubleDoor
   where
     triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoubleDoor c cond a b is
       where
-        is = [newKey wls..]
+        is = [IM.newKey wls..]
 
 mkTriggerDoor 
     :: Color 

src/Dodge/Picture/Layer.hs

@@ -8,21 +8,15 @@ module Dodge.Picture.Layer
     ) where
 import Dodge.Picture.Layer.Data
 import Picture
-
+{- | Uses a layer to set the depth.  -}
-{- | Uses a layer to set the depth.
- -}
 onLayer :: Layer -> Picture -> Picture
 onLayer l = setDepth $ 1 - fromIntegral (levLayer l) / 100 
-
 {- | Set a depth according to a list of numbers.
 Lists are lexicographically ordered if input values are always less than 100.
-Higher numbers will get placed on top of lower numbers.
+Higher numbers will get placed on top of lower numbers.  -}
--}
 onLayerL :: [Int] -> Picture -> Picture
 onLayerL is = setDepth (1 - sum (zipWith (/) (map fromIntegral is) $ map (100 **) [1..])) 
-
+{- | For depth testing, set layer values.  -}
-{- | For depth testing, set layer values.
- -}
 levLayer :: Layer -> Int
 levLayer BgLayer            = 20
 levLayer PressPlateLayer    = 45
@@ -38,3 +32,4 @@ levLayer ShadowLayer        = 75
 levLayer LabelLayer         = 80
 levLayer InvLayer           = 85
 levLayer MenuDepth          = 90
+levLayer DebugLayer         = 99

src/Dodge/Picture/Layer/Data.hs

@@ -16,3 +16,4 @@ data Layer
     | UPtLayer
     | HPtLayer
     | GloomLayer
+    | DebugLayer

src/Dodge/Room.hs

@@ -309,9 +309,12 @@ weaponBetweenPillars = do
             ,sPS crPos1 (d crPos1) randC1
             ,sPS crPos2 (d crPos2) randC1
             ]
-    (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (over rmPS (++plmnts) roomPillars)
+        theRoom = roomPillars & rmPS %~ (++ plmnts)
+--                    & rmPolys %~ (rectNSWE 300 0 0 300 :)
+    (fmap connectRoom . randomiseOutLinks) =<< filterLinks f theRoom
   where 
     f (_,a) = a == 0
+    --f (_,_) = True -- this is probably preferable...
 
 weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
 weaponLongCorridor = do

src/Dodge/Room/Corridor.hs

@@ -2,13 +2,12 @@ module Dodge.Room.Corridor
     where
 import Dodge.Room.Data
 import Geometry
-
+{- | First exit due north, two other exits at angles next to this.
-{- First exit due north, two other exits at angles next to this.
+ Entrance from south.  -}
- Entrance from south.
- -}
 corridor :: Room
 corridor = Room
     { _rmPolys = [rectNSWE 80 0 0 40
+    --{ _rmPolys = [rectNSWE 90 (-10) 0 40
 --                 ,[(0,80), (0,80) +.+ rotateV (pi/3) (40,0),(40,80)]
 --                 ,[(40,0), (0,0) +.+ rotateV (0-pi/3) (40,0),( 0, 0)]
                  ]
@@ -24,6 +23,26 @@ corridor = Room
         ,((20,70), negate $ pi/6)
         ,((20,10)    ,pi)
         ]
+{- | Debug drop-in copy of corridor  -}
+corridorDebug :: Room
+corridorDebug = Room
+    { _rmPolys = 
+        [   rectNSWE 80 0 0 40
+        --,   [ (0,0), (0,200) , (200,100)]
+        --,   [ (0,0), (0,20) , (20,10)]
+        ]
+    , _rmLinks = lnks
+    , _rmPath  = concatMap (doublePair . (,) (20,60) . fst) lnks
+    , _rmPS    = []
+    , _rmBound = [ rectNSWE 50 30 0 40 ]
+    }
+  where 
+    lnks = 
+        [((20,70)  ,0)
+        ,((20,70), pi/6)
+        ,((20,70), negate $ pi/6)
+        ,((20,10)    ,pi)
+        ]
 corridorN :: Room
 corridorN = Room
     { _rmPolys = [rectNSWE 80 0 0 40

src/Dodge/Update.hs

@@ -91,7 +91,7 @@ updateCreatureGroups w = w & creatureGroups %~
 
 updateTriggers :: World -> World
 updateTriggers w 
-    | ResetLevel 1 `S.member` _worldTriggers w = generateFromList levx $ initialWorld 
+    | ResetLevel 1 `S.member` _worldTriggers w = generateLevelFromRoomList levx $ initialWorld 
         & randGen       .~ _randGen w
         & config        .~ _config w
         & menuLayers    .~ []

src/Dodge/WallCreatureCollisions.hs

@@ -1,6 +1,4 @@
-{- |
+{- | Deals with moving creature wall collisions.  -}
-Deals with moving creature wall collisions.
- -}
 module Dodge.WallCreatureCollisions where
 import Dodge.Data
 import Dodge.Creature.State.Data
@@ -18,6 +16,7 @@ colCrsWalls w = over creatures (fmap (colCrWall w)) w
 
 colCrWall :: World -> Creature -> Creature
 colCrWall w c 
+    | _crID c == 0 = c -- for noclip
     | p1 == p2  = pushOrCrush ls c
     | otherwise = c & crPos %~
         collideCorners rad wallPoints

src/Dodge/WorldEvent/Cloud.hs

@@ -5,14 +5,14 @@ import Dodge.Data
 import Dodge.Base
 --import Geometry
 import Picture
+import qualified IntMapHelp as IM
 
 import Control.Lens
-import qualified Data.IntMap as IM
 
 makeCloudAt :: Float -> Int -> (Cloud -> Picture) -> Point2 -> World -> World
 makeCloudAt rad t drawFunc p w 
         = w & clouds %~ IM.insert i theCloud
-    where i = newKey $ _clouds w
+    where i = IM.newKey $ _clouds w
           theCloud = Cloud { _clID = i
                            , _clPos = p
                            , _clVel = (0,0)

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -19,9 +19,9 @@ import Dodge.RandomHelp
 import Dodge.Debug
 import Picture
 import Geometry
+import qualified IntMapHelp as IM
 
 import Control.Lens
-import qualified Data.IntMap.Strict as IM
 import System.Random
 import Control.Monad.State
 import Data.Function (on)
@@ -228,7 +228,7 @@ makeGasCloud pos vel w = w
     & clouds    %~ IM.insert i theCloud
     & randGen   .~ g
   where 
-    i = newKey $ _clouds w
+    i = IM.newKey $ _clouds w
     theCloud = Cloud { _clID = i
                      , _clPos = pos
                      , _clVel = vel

src/IntMapHelp.hs

@@ -0,0 +1,21 @@
+module IntMapHelp
+    ( module Data.IntMap.Strict
+    , newKey
+    , insertNewKey
+    , insertWithNewKeys
+    )
+    where
+--import Data.List hiding (foldr,insert)
+import Data.IntMap.Strict
+{- | Find a key value one higher than any key in the map, or zero if the map is
+ - empty -}
+newKey :: IntMap a -> Int
+newKey = maybe 0 ((+ 1) . fst) . lookupMax
+{- | Insert an element with some new key. -}
+insertNewKey :: a -> IntMap a -> IntMap a
+insertNewKey x m = case lookupMax m of
+    Nothing     -> singleton 0 x
+    Just (k,_)  -> insert (k+1) x m
+{- | Insert a list of values with new keys -}
+insertWithNewKeys :: [a] -> IntMap a -> IntMap a
+insertWithNewKeys xs m = union m $ fromList $ zip [newKey m..] xs