Add source files, commit before reverting pictures to lists

src/Dodge/Base.hs

@@ -0,0 +1,740 @@
+--{-# LANGUAGE Strict #-}
+{-# LANGUAGE BangPatterns #-}
+module Dodge.Base where
+-- imports {{{
+import Dodge.Data
+
+import Geometry
+import Picture
+
+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
+
+-- }}}
+--
+you :: World -> Creature
+you w = _creatures w IM.! _yourID w
+
+aCrPos :: Int -> World -> Point2
+aCrPos i w = _crPos $ _creatures w IM.! i
+
+yourItem :: World -> Item
+yourItem w = _crInv (you w) IM.! _crInvSel (you w)
+
+yourItemRef w = (creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)))
+
+halfWidth,halfHeight :: World -> Float
+halfWidth w = _windowX w / 2
+halfHeight w = _windowY w / 2
+
+hasLOS :: Point2 -> Point2 -> World -> Bool
+{-# INLINE hasLOS #-}
+hasLOS p1 p2 w = (not $ collidePointWallsSimple p1 p2 nearbyWalls) 
+                    && (not $ collidePointSmoke p1 p2 nearbySmoke)
+    where nearbyWalls = wallsAlongLine p1 p2 w
+          nearbySmoke = _smoke w -- smokeAlongLine p1 p2 w
+
+smokeLOS :: Point2 -> Point2 -> World -> Bool
+smokeLOS p1 p2 w = not $ collidePointSmoke p1 p2 nearbySmoke
+    where nearbySmoke = _smoke w
+
+hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
+hasLOSIndirect p1 p2 w = case collidePointIndirect p1 p2 $ wallsAlongLine p1 p2 w
+                         of Just _ -> False
+                            Nothing -> True && smokeLOS p1 p2 w
+
+isWalkable :: Point2 -> Point2 -> World -> Bool
+isWalkable p1 p2 w = not $ collidePointWalkable p1 p2 nearbyWalls
+    where nearbyWalls = wallsAlongLine p1 p2 w
+
+canSee :: Int -> Int -> World -> Bool
+canSee i j w = hasLOS p1 p2 w
+--canSee i j w = not $ collidePointWallsSimple p1 p2
+--                                      nearbyWalls
+    where p1 = _crPos (_creatures w IM.! i)
+          p2 = _crPos (_creatures w IM.! j)
+          nearbyWalls = wallsAlongLine p1 p2 w
+
+canSeePoint :: Int -> Point2 -> World -> Bool
+canSeePoint i p w = hasLOS p1 p w
+--canSeePoint i p w = case collidePointWalls p1 p nearbyWalls
+--                    of Just _ -> False
+--                       Nothing -> True
+    where nearbyWalls = wallsAlongLine p1 p w
+          p1 = _crPos (_creatures w IM.! i)
+
+
+pathToPointFireable :: Int -> Point2 -> World -> Bool
+pathToPointFireable i p w = not $ collidePointWallsSimple (_crPos (_creatures w IM.! i))
+                                                          p
+                                                          walls
+    where walls = IM.filter (not . isJust . \wl -> wl ^? blHP) 
+                    $ wallsAlongLine p1 p w
+          p1 = _crPos (_creatures w IM.! i)
+
+canSeePointAll :: Int -> Point2 -> World -> Bool
+canSeePointAll i targPos w = and $ map (flip (canSeePoint i) w . (\p -> (targPos +.+ radius *.* p)))
+                                  [(1,0),(0,1),(-1,0),(0,-1)]
+    where cr = _creatures w IM.! i
+          cpos = _crPos cr
+          radius = _crRad cr
+
+canSeeAny :: Int -> Int -> World -> Bool
+canSeeAny fromID toID w = or $ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p)))
+                                  [(1,0),(0,1),(-1,0),(0,-1)]
+    where cr = _creatures w IM.! toID
+          cpos = _crPos cr
+          radius = _crRad cr
+
+canSeeAll :: Int -> Int -> World -> Bool
+canSeeAll fromID toID w = and $ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p)))
+                                  [(1,0),(0,1),(-1,0),(0,-1)]
+    where cr = _creatures w IM.! toID
+          cpos = _crPos cr
+          radius = _crRad cr
+
+canWalk :: Int -> Int -> World -> Bool
+canWalk i j w = not $ collidePointWalkable ipos jpos $ wallsAlongLine ipos jpos w
+    where ipos = _crPos (_creatures w IM.! i)
+          jpos = _crPos (_creatures w IM.! j)
+
+canSeeIndirect :: Int -> Int -> World -> Bool
+canSeeIndirect i j w = case collidePointIndirect ipos jpos $ wallsAlongLine ipos jpos w
+                         of Just _ -> False
+                            Nothing -> True && smokeLOS ipos jpos w
+    where ipos = _crPos (_creatures w IM.! i)
+          jpos = _crPos (_creatures w IM.! j)
+    
+canSeeFire :: Point2 -> Point2 -> World -> Bool
+canSeeFire p p' w = (not $ collidePointFireVision p p' $ wallsAlongLine p p' w)
+                    && smokeLOS p p' w
+
+canSeeFireVision :: Int -> Int -> World -> Bool
+canSeeFireVision i j w = (not $ collidePointFireVision ipos jpos $ wallsAlongLine ipos jpos w)
+                            && smokeLOS ipos jpos w
+    where ipos = _crPos (_creatures w IM.! i)
+          jpos = _crPos (_creatures w IM.! j)
+
+canSeeFireVisionAny :: Int -> Int -> World -> Bool
+canSeeFireVisionAny i j w = (not $ and $ fmap ($ (wallsAlongLine (_crPos icr) (_crPos jcr) w) )
+                                 $ zipWith collidePointFireVision ips jps
+                            ) && smokeLOS (_crPos icr) (_crPos jcr) w
+    where icr = _creatures w IM.! i
+          jcr = _creatures w IM.! j
+          ips = map (\p -> (_crPos icr +.+ _crRad icr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
+          jps = map (\p -> (_crPos jcr +.+ _crRad jcr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
+
+
+canSeeFireVisionAll :: Int -> Int -> World -> Bool
+canSeeFireVisionAll i j w = (not $ or $ fmap ($ (wallsAlongLine (_crPos icr) (_crPos jcr) w) )
+                                 $ zipWith collidePointFireVision ips jps
+                            ) && smokeLOS (_crPos icr) (_crPos jcr) w
+    where icr = _creatures w IM.! i
+          jcr = _creatures w IM.! j
+          ips = map (\p -> (_crPos icr +.+ _crRad icr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
+          jps = map (\p -> (_crPos jcr +.+ _crRad jcr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
+
+-- looks for first collision of a point with walls
+-- if found, returns wall
+-- I'm sure there is a better way of doing this, one that propagates Nothing in a nice way
+
+--wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
+--wallsOnLine p1 p2 ws = hitWalls
+--    where hitPoint w = myIntersectSegSeg p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
+--          hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws)
+
+wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
+wallsOnLine p1 p2 ws = hitWalls
+    where hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
+          hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws)
+
+wallOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Wall
+wallOnLine p1 p2 ws 
+    = listToMaybe $ sortBy f hitWalls
+    where hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
+    --where hitPoint w = myIntersectSegSeg p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
+          hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws)
+          f w1 w2 = compare (magV (p1 -.- fromJust (hitPoint w1))) (magV (p1 -.- fromJust (hitPoint w2)))
+
+wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> [Wall]
+wallsOnCirc p r wls = IM.elems $ IM.filter f wls
+    where f wl = circOnLine (_wlLine wl !! 0) (_wlLine wl !! 1) p r
+
+wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
+wallsNearPoint p w =  IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+    where (x,y) = zoneOfPoint p
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+-- possible BUG, was associated with thingsHitLongLine
+wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
+{-# INLINE wallsAlongLine #-}
+--wallsAlongLine a b w = IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfLine a b]
+--    where f i m = case IM.lookup i m of Just val -> val
+--                                        _        -> IM.empty
+wallsAlongLine a b w = IM.foldrWithKey' g IM.empty kps
+    where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
+          kps = zoneOfLine' a b
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+wallsNearZone' :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall
+{-# INLINE wallsNearZone' #-}
+wallsNearZone' im w = IM.foldrWithKey' g IM.empty im
+    where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+
+wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
+wallsAlongCirc p r w =  IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfCircle p r]
+    where f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+allWalls :: World -> IM.IntMap Wall
+allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _wallsZone w
+
+creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature
+creaturesNearPoint p w =  IM.unions [f b $ f a $ _creaturesZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+    where (x,y) = zoneOfPoint p
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+cloudsNearPoint :: Point2 -> World -> IM.IntMap Cloud
+cloudsNearPoint p w =  IM.unions [f b $ f a $ _cloudsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+    where (x,y) = zoneOfPoint p
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+-- possible BUG, occurs when used in thingsHitLongLine
+creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
+--creaturesAlongLine a b w = IM.unions [f y $ f x $ _creaturesZone w | (x,y) <- zoneOfLine a b]
+--    where f i m = case IM.lookup i m of Just val -> val
+--                                        _        -> IM.empty
+creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty kps
+    where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _creaturesZone w) s))
+          kps = zoneOfLine' a b
+          f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+zoneSize :: Float
+zoneSize = 50
+--zoneSize = 100
+          
+floorHun :: Float -> Int
+floorHun x = floor $ x / zoneSize
+zoneOfPoint :: Point2 -> (Int,Int)
+zoneOfPoint (x,y) = (floorHun x, floorHun y)
+
+zoneNearPoint :: Point2 -> [(Int,Int)]
+zoneNearPoint (x',y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
+    where x = floorHun x'
+          y = floorHun y'
+
+zoneAroundPoint :: Point2 -> [(Int,Int)]
+zoneAroundPoint (x',y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]]
+    where x = floorHun x'
+          y = floorHun y'
+
+zoneAroundPoint' :: Int -> Point2 -> IM.IntMap IS.IntSet
+zoneAroundPoint' i (x',y') = IM.fromSet (const ys) xs
+    where x = floorHun x'
+          y = floorHun y'
+          xs = IS.fromAscList [x-i..x+i]
+          ys = IS.fromAscList [y-i..y+i]
+
+-- the laser seemed to be occasionally missing creatures,
+-- if this reoccurs, maybe change
+-- divide line factor from 2 to 1.5
+bres :: Point2 -> Point2 -> [(Int,Int)]
+bres a b = bresenham (zoneOfPoint a) (zoneOfPoint b)
+
+bresx :: Point2 -> Point2 -> [(Int,Int)]
+bresx a b = bresenham (x-1,y-1) (x'-1,y'-1)
+    where (x,y) = zoneOfPoint a
+          (x',y') = zoneOfPoint b
+
+zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
+zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f 
+                                 $ bresenham (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb))
+    where f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
+--zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f 
+--                                 $ bresenham (zoneOfPoint (aa-n,ab-n)) (zoneOfPoint (ba-n,bb-n))
+--    where f (x,y) = [(p,r) | p <-[x,x+1] , r<-[y,y+1]]
+--          n = zoneSize * 0.5
+
+expandLine :: [(Int,Int)] -> IM.IntMap IS.IntSet
+{-# INLINE expandLine #-}
+expandLine xs = IM.map expandSet
+                  $ IM.unionsWith IS.union [im, IM.mapKeysMonotonic (+1) im, IM.mapKeysMonotonic (+2) im]
+    where im = IM.fromListWith IS.union $ map (\(a,b)->(a,IS.singleton b)) xs
+          expandSet s = IS.insert (mk+2) $ IS.insert (mk+1) s
+          --expandSet s = s
+                where mk = IS.findMax s
+
+zoneOfLine' :: Point2 -> Point2 -> IM.IntMap IS.IntSet
+{-# INLINE zoneOfLine' #-}
+zoneOfLine' a b = expandLine $ bresenham (x-1,y-1) (x'-1,y'-1)
+    where (x,y) = zoneOfPoint a
+          (x',y') = zoneOfPoint b
+                        
+--zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b
+--zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b
+
+zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
+zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
+
+-- looking at this again, I am not convinced it deals correctly with the
+-- rotation of the world
+zoneOfScreen :: World -> [(Int,Int)]
+zoneOfScreen w = [(a,b) | a <- [x - n .. x + n]
+                        , b <- [y - n .. y + n]
+                 ]
+    where (x,y) = zoneOfPoint $ _cameraPos w
+          n = ceiling $ wh / (_cameraZoom w * zoneSize)
+          wh = max (_windowX w) (_windowY w)
+
+zoneOfDoubleScreen :: World -> [(Int,Int)]
+zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n]
+                        , b <- [y - n .. y + n]
+                 ]
+    where (x,y) = zoneOfPoint $ _cameraPos w
+          n = (ceiling $ wh / (_cameraZoom w * zoneSize)) * 2
+          wh = max (_windowX w) (_windowY w)
+
+zoneOfSight :: World -> [(Int,Int)]
+zoneOfSight w = [(a,b) | a <- [minimum xs .. maximum xs]
+                       , b <- [minimum ys .. maximum ys]
+                ]
+    where (xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraCenter w]
+
+screenPolygon :: World -> [Point2]
+screenPolygon w = [tr,tl,bl,br]
+    where scRot  = rotateV (_cameraRot w)
+          scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
+          scTran p = p +.+ _cameraPos w
+          tr = scTran $ scRot $ scZoom ( halfWidth w, halfHeight w) 
+          tl = scTran $ scRot $ scZoom (-halfWidth w, halfHeight w) 
+          br = scTran $ scRot $ scZoom ( halfWidth w,-halfHeight w)
+          bl = scTran $ scRot $ scZoom (-halfWidth w,-halfHeight w)
+
+wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
+wallsNearZones is w = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
+    where f i m = case IM.lookup i m of Just val -> val
+                                        _        -> IM.empty
+
+ixZone :: IM.IntMap (IM.IntMap a) -> Point2 -> a
+ixZone z (x,y) = z IM.! floorHun x IM.! floorHun y
+
+ixNZ :: IM.IntMap (IM.IntMap a) -> Point2 -> [a]
+ixNZ z p = lookLookups (zoneNearPoint p) z
+
+lookLookup :: Int -> Int -> (IM.IntMap (IM.IntMap a)) -> Maybe a
+lookLookup i j z = case IM.lookup i z of
+                        Just z' -> IM.lookup j z'
+                        Nothing -> Nothing
+
+lookLookups :: [(Int,Int)] -> (IM.IntMap (IM.IntMap a)) -> [a]
+lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
+
+-- looks for first collision of a point with walls
+-- if found, gives point and reflection velocity
+collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
+collidePointWalls p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe 
+                                        (( \(x:y:_) -> fmap (flip (,)
+                                                             (reflectIn (x -.- y) (p2 -.- p1))
+                                                            . (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
+                                                            ) (intersectSegSeg' p1 p2 x y)
+                                         ) . _wlLine
+                                        ) ws
+    where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+-- looks for if a point collides with walls
+collidePointWallsSimple :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
+collidePointWallsSimple p1 p2 = any $ isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
+                                        . _wlLine
+
+collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
+collidePointWalkable p1 p2 ws = any (isJust 
+                                    . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
+                                    . _wlLine
+                                    ) unwalkableWalls
+    where unwalkableWalls = IM.filter notDoor ws
+          notDoor (AutoDoor {}) = False
+          notDoor _         = True
+
+furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
+furthestPointWalkable p1 p2 ws = head $ (sortBy (compare `on` dist p1) $ IM.elems 
+                                    $ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
+                                                    . _wlLine
+                                                  ) ws
+                                        ) ++ [p2]
+
+collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
+collidePointIndirect p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems 
+                                    $ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
+                                                    . _wlLine
+                                                  ) notWindows
+    where notWindows = IM.filter (not . _wlIsSeeThrough) ws
+
+collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
+collidePointFire p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems 
+                                    $ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
+                                                    . _wlLine
+                                                  ) notWindows
+    where notWindows = IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))
+                                 ) ws
+
+collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
+collidePointFireVision p1 p2 ws =  any ( isJust
+                                       . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) 
+                                       . _wlLine
+                                       ) 
+                                       $ IM.filter notBlockWindow ws
+    where notBlockWindow wl = case wl ^? blHP of
+                                Just _  -> not $ _wlIsSeeThrough wl
+                                Nothing -> True
+
+collidePointSmoke :: Point2 -> Point2 -> [Smoke] -> Bool
+collidePointSmoke a b = any $ isJust . uncurry (intersectSegSeg' a b) . smokePerpLine a b
+
+smokePerpLine :: Point2 -> Point2 -> Smoke -> (Point2,Point2)
+smokePerpLine a b sm = (p +.+ orth, p -.- orth)
+    where
+        p = _smPos sm
+        orth = _smRad sm *.* safeNormalizeV (vNormal (a -.- b))
+
+-- shit this is ugly
+lineOfThickness :: Float -> [Point2] -> Picture
+lineOfThickness t = pictures . f
+    where f (x:y:ys) 
+            | x == y = f (x:ys)
+            | otherwise 
+                     = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
+          f _        = []
+          n a b      = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
+
+wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture
+wedgeOfThickness t x y 
+    | x == y    = blank
+    | otherwise = pictures [uncurry translate x $ circleSolid (0.5*t)
+                           ,polygon [x +.+ n x y, x -.- n x y, y]
+                           ]
+    where n a b      = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
+
+insertInZoneWith :: Int -> Int -> (a -> a -> a) -> a -> IM.IntMap (IM.IntMap a) 
+                                            -> IM.IntMap (IM.IntMap a)
+insertInZoneWith x y fun obj = IM.insertWith f x $ IM.singleton y obj
+    where-- f :: IM.IntMap a -> IM.IntMap a -> IM.IntMap a
+          f _ = IM.insertWith fun y obj
+
+insertIMInZone :: Int -> Int -> Int -> a -> IM.IntMap (IM.IntMap (IM.IntMap a)) 
+                                            -> IM.IntMap (IM.IntMap (IM.IntMap a))
+insertIMInZone x y obid obj = IM.insertWith f x $ IM.singleton y $ IM.singleton obid obj
+    where f _ = IM.insertWith g y $ IM.singleton obid obj
+          g _ = IM.insert obid obj
+
+adjustIMZone :: (a -> a) -> Int -> Int -> Int -> IM.IntMap (IM.IntMap (IM.IntMap a)) 
+                                              -> IM.IntMap (IM.IntMap (IM.IntMap a))
+adjustIMZone f x y n m = IM.adjust f' x m
+    where f'  = IM.adjust f'' y
+          f'' = IM.adjust f n
+
+
+newKey :: IM.IntMap a -> Int
+newKey m = case IM.lookupMax m of
+                        Just (n,_)  -> n+1
+                        Nothing     -> 0
+
+newParticleKey :: World -> Int
+newParticleKey w = case IM.lookupMax (_particles w) of
+                        Just (n,_)  -> n+1
+                        Nothing     -> 0
+newCrKey :: World -> Int
+newCrKey w = case IM.lookupMax (_creatures w) of
+                        Just (n,_)  -> n+1
+                        Nothing     -> 0
+
+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
+
+reflectPointCreature :: Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int)
+reflectPointCreature p1 p2 cr = 
+    case collidePointCirc p1 p2 (_crRad cr) (_crPos cr) of
+        Nothing -> Nothing
+        Just p3 -> Just ( p1
+                        , errorNormalizeV 35 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr) 
+                            +.+ (_crPos cr -.- _crOldPos cr)
+                        --, errorNormalizeV 36 $ 
+                        --  ssaTriPoint p1 (_crPos cr) p2 (_crRad cr)
+                        --     -.- _crOldPos cr
+                        , _crID cr)
+
+reflectPointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int)
+reflectPointCreatures p1 p2 cs = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
+                                                (reflectPointCreature p1 p2) cs
+    where f (a,_,_) (b,_,_) = compare (magV (a -.- p1)) (magV (b -.- p1))
+
+
+reflectCircCreature :: Float -> Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int)
+reflectCircCreature rad p1 p2 cr = 
+    case collidePointCirc p1 p2 (rad + _crRad cr) (_crPos cr) of
+        Nothing -> Nothing
+        Just p3 -> Just ( p1
+                        , errorNormalizeV 37 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr) 
+                            +.+ (_crPos cr -.- _crOldPos cr)
+                        --, errorNormalizeV 38 $ 
+                        --  ssaTriPoint p1 (_crPos cr) p2 (_crRad cr)
+                        --     -.- _crOldPos cr
+                        , _crID cr)
+
+reflectCircCreatures :: Float -> Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int)
+reflectCircCreatures rad p1 p2 cs = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
+                                                (reflectCircCreature rad p1 p2) cs
+    where f (a,_,_) (b,_,_) = compare (magV (a -.- p1)) (magV (b -.- p1))
+
+-- collides a point with forcefields
+-- if found, returns point of collision, deflection if required, and the id
+collidePointFFs = undefined
+collidePointFF  = undefined
+--
+--collidePointFFs :: Point2 -> Point2 -> StdGen -> IM.IntMap ForceField 
+--                    -> Maybe (Point2,(Maybe (Point2,StdGen),Int))
+--collidePointFFs p1 p2 g fs = listToMaybe $ sortBy f $ IM.elems 
+--                            $ IM.mapMaybe (collidePointFF p1 p2 g) fs
+--    where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+--
+--collidePointFF :: Point2 -> Point2 -> StdGen -> ForceField 
+--                    -> Maybe (Point2,(Maybe (Point2,StdGen),Int))
+--collidePointFF p1 p2 g ff = fmap f ip
+--    where (p3:p4:_) = _ffLine ff
+--          ip  = intersectSegSeg' p1 p2 p3 p4
+--          ref = (_ffDeflect ff) <*> Just g <*> Just (p2 -.- p1) <*> Just ff
+--          f p = (p, (ref, _ffID ff))
+--
+
+-- looks for first collision of a point with walls
+-- if found, gives point and reflection velocity, reflection damped in normal
+collidePointWalls' :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
+collidePointWalls' p1 p2 ws 
+    = listToMaybe $ sortBy f $ IM.elems 
+        $ IM.mapMaybe 
+            (( \(x:y:_) -> fmap (flip (,) (reflectInParam 0.5 (x -.- y) (p2 -.- p1)) 
+                                . (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
+                                ) 
+                                (intersectSegSeg' p1 p2 x y)
+                                         ) . _wlLine
+                                        ) ws
+    where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+
+-- looks for first collision of a circle with walls
+-- if found, gives point and reflection velocity, reflection damped in normal
+collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
+collideCircWalls' p1 p2 rad ws 
+    = listToMaybe $ sortBy f $ IM.elems 
+        $ IM.mapMaybe 
+            (( \(x:y:_) -> fmap (flip (,) (reflectInParam 0.5 (x -.- y) (p2 -.- p1)) 
+                                . (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
+                                ) 
+                                (intersectSegSeg' p1 p2 x y)
+                                         ) . shiftByRad . _wlLine
+                                        ) ws
+    where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+          shiftByRad (a:b:_) = map ((+.+) (rad *.* normalizeV (vNormal (a -.- b))))
+                                   [a +.+ rad *.* (normalizeV (a -.-b))
+                                   ,b +.+ rad *.* (normalizeV (b -.-a))
+                                   ]
+-- this shifts the wall out, and for outer corners extends the wall
+-- not sure what this does for inner corners, hopefully won't cause a problem
+-- the alternative would be to separately bounce off corner points...
+-- unfortunately, doesn't allow for collisions when the circle spawns on the
+-- wall
+
+-- looks for first collision of a point with walls
+-- if found, gives point and normal of wall
+collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
+collidePointWallsNorm p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe 
+                                        (( \(x:y:_) -> fmap (flip (,) ( vNormal $ x -.- y )) 
+                                                            (intersectSegSeg' p1 p2 x y)
+                                         ) . _wlLine
+                                        ) ws
+    where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+
+-- looks for first collision of a point with walls
+-- if found, gives point and colour of wall
+collidePointWallsCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Color)
+collidePointWallsCol p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe 
+                                        ( (\(m, c) -> fmap (flip (,) c) m)
+                                        . (\w -> (intersectSegSeg' p1 p2 
+                                                    (_wlLine w !! 0) (_wlLine w !! 1), _wlColor w))
+                                        ) ws
+    where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+-- looks for first collision of a point with walls
+-- if found, gives point, and normal and colour of wall
+collidePointWallsNormCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2,Color)
+collidePointWallsNormCol p1 p2 ws 
+    = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe m ws
+    where f (a,_,_) (b,_,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
+          ls w = let (x:y:_) = _wlLine w
+                 in  (intersectSegSeg' p1 p2 x y, vNormal (x -.- y), _wlColor w)
+          m w = let (a1,a2,a3) = ls w
+                in  fmap (\a4 -> (a4,a2,a3)) a1
+
+--returns the first creature, if any, that a point intersects with
+collidePointCreatures :: Point2 -> Point2 -> World -> Maybe Int
+collidePointCreatures p1 p2 w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
+                                IM.mapMaybe (\x -> 
+                                        collidePointCirc' p1 p2 (_crRad x) (_crPos x)
+                                       ) 
+                                       (_creatures w)
+    where csnd (_,a) (_,b) = compare a b
+--as for collidePointCreatures, only increases the radius of creatures by a
+--fixed amount, thus collides a moving circle with creaures
+collideCircCreatures :: Point2 -> Point2 -> Float -> World -> Maybe Int
+collideCircCreatures p1 p2 rad w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
+                                IM.mapMaybe (\x -> 
+                                        collidePointCirc' p1 p2 (rad + _crRad x) (_crPos x)
+                                       ) 
+                                       (_creatures w)
+    where csnd (_,a) (_,b) = compare a b
+
+
+--returns the first creature, if any, that a point intersects with, gives point
+--in creature on line
+collidePointCrsPoint :: Point2 -> Point2 -> World -> Maybe (Point2,Int)
+collidePointCrsPoint p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
+                                IM.mapMaybe (\x -> 
+                                        collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
+                                       ) 
+                                       (_creatures w)
+    where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
+          f (cID,(p,_)) = (p,cID)
+collideCircCrsPoint :: Point2 -> Point2 -> Float -> World -> Maybe (Point2,Int)
+collideCircCrsPoint p1 p2 rad w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
+                                IM.mapMaybe (\x -> 
+                                        collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x)
+                                       ) 
+                                       (_creatures w)
+    where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
+          f (cID,(p,_)) = (p,cID)
+
+
+-- makes a creatures not hittable
+collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
+collidePointCrsWithoutPoint cid p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
+                                IM.mapMaybe (\x -> 
+                                        collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
+                                       ) 
+                                       (IM.delete cid $ _creatures w)
+    where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
+          f (cID,(p,_)) = (p,cID)
+
+circOnSomeWall :: Point2 -> Float -> World -> Bool
+circOnSomeWall p rad w = any (\(x:y:_) -> circOnLine x y p rad) 
+                            $ fmap _wlLine $ IM.elems $ wallsNearPoint p w
+
+crsNearLine :: Float -> [Point2] -> World -> Bool
+crsNearLine d (p1:p2:_) w = any (\c -> circOnLine p1 p2 (_crPos c) (d + _crRad c)) 
+                                $ IM.filter (\cr -> _crMass cr > 4) $ _creatures w
+
+crsNearPoint :: Float -> Point2 -> World -> Bool
+crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures w)
+
+crsOnLine :: Point2 -> Point2 -> World -> [Creature]
+crsOnLine p1 p2 w = IM.elems 
+                        $ IM.filter (\cr -> circOnLine p1 p2 (_crPos cr) (_crRad cr))
+                        $ _creatures w
+
+crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature]
+crsOnThickLine thickness p1 p2 w = IM.elems 
+                        $ IM.filter (\cr -> circOnLine p1 p2 (_crPos cr) (_crRad cr + thickness))
+                        $ _creatures w
+
+nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
+nearestCrInRad p r w = let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w
+                           sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
+                       in  listToMaybe sortedCrs
+
+nearestCrInTri :: Point2 -> Float -> Float -> World -> Maybe Creature
+nearestCrInTri p dir x w 
+    = let crs = IM.filter (\cr -> errorPointInPolygon 1 (_crPos cr) tri) $ _creatures w
+          sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
+      in  listToMaybe sortedCrs
+        where tri = [p 
+                    ,p +.+ rotateV (dir-pi/4) (x,0)
+                    ,p +.+ rotateV (dir+pi/4) (x,0)
+                    ]
+
+nearestCrInFront :: Point2 -> Float -> Float -> World -> Maybe Creature
+nearestCrInFront p dir x w 
+    = let crs = IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
+          sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
+      in  listToMaybe sortedCrs
+        where rec = [p
+                    ,pR
+                    ,pR1
+                    ,pL1
+                    ,pL
+                    ]
+              pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0)
+              pL = p +.+ rotateV (dir + pi*(3/8)) (x/2,0)
+              pR1 = pR +.+ rotateV dir (x/2,0)
+              pL1 = pL +.+ rotateV dir (x/2,0)
+
+crInPolygon :: Creature -> [Point2] -> Bool
+crInPolygon cr xs = errorPointInPolygon 3 (_crPos cr) xs
+
+onLayer :: Layer -> Picture -> Picture
+onLayer l = setDepth (fromIntegral (levLayer l) / 100)
+
+--onLayer :: Layer -> Picture -> [(Picture, [Int])]
+--onLayer l p = [(p, [levLayer l])]
+
+onLayerL :: [Int] -> Picture -> Picture
+onLayerL is = setDepth (sum $ zipWith (/) (map fromIntegral is) $ map (\x->100**x) [1..])
+
+levLayer :: Layer -> Int
+levLayer BgLayer            = 20
+levLayer PressPlateLayer    = 45
+levLayer CorpseLayer        = 50
+levLayer FlItLayer          = 55
+levLayer CrLayer            = 60
+levLayer WlLayer            = 65
+levLayer GloomLayer         = 67
+levLayer UPtLayer           = 70
+levLayer PtLayer            = 72
+levLayer HPtLayer           = 73
+levLayer ShadowLayer        = 75   
+levLayer LabelLayer         = 80
+levLayer InvLayer           = 85
+levLayer MenuLayer          = 90
+
+mouseWorldPos :: World -> Point2
+mouseWorldPos w = _cameraPos w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
+
+logistic :: Float -> Float -> Float -> (Float -> Float)
+logistic x0 l k x = l / (1 + exp (k*(x0 - x)))
+
+wallLOS :: [Point2] -> Point2 -> Point2 -> Bool
+{-# INLINE wallLOS #-}
+wallLOS !(x:y:_) !c !p = isRHS c x y || isLHS p x' y' || isLHS c p x || isRHS c p y
+    where n = 10 *.* (normV . vNormal $ y -.- x)
+          x' = x +.+ n
+          y' = y +.+ n
+
+wallsLOS :: Foldable t => t [Point2] -> Point2 -> Point2 -> Bool
+{-# INLINE wallsLOS #-}
+wallsLOS !ls !c !p = all (\l -> wallLOS l c p) ls
+
+translateDrawing = translate
+rotateDrawing = rotate