--{-# 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

-- }}}
--
leftPad :: Int -> a -> [a] -> [a]
leftPad i x xs = reverse $ take i $ reverse (take i xs) ++ repeat x

rightPad :: Int -> a -> [a] -> [a]
rightPad i x xs = take i $ xs ++ repeat x

midPad :: Int -> a -> [a] -> [a] -> [a]
midPad i x xs ys = xs ++ replicate j x ++ ys
    where j = i - (length xs + length ys)

midPadL :: Int -> a -> [a] -> [a] -> [a]
midPadL i x xs ys = take j (xs ++ repeat x) ++ ys
    where j = i - length ys

takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil f ps = case span (not . f) ps of
    (xs,[])    -> xs
    (xs,(y:_)) -> xs ++ [y]

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) 
    where nearbyWalls = wallsAlongLine p1 p2 w

hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
hasLOSIndirect p1 p2 w = case collidePointIndirect p1 p2 $ wallsAlongLine p1 p2 w
                         of Just _ -> False
                            Nothing -> True

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

canSeeFireVision :: Int -> Int -> World -> Bool
canSeeFireVision i j w = (not $ collidePointFireVision ipos jpos $ wallsAlongLine 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
    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
    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)

wallNormal :: Wall -> Point2
wallNormal wl = normalizeV . vNormal $ a -.- b
    where (a:b:_) = _wlLine wl

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 = circOnSeg (_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 = digitalLine (zoneOfPoint a) (zoneOfPoint b)

bresx :: Point2 -> Point2 -> [(Int,Int)]
bresx a b = digitalLine (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 
                                 $ digitalLine (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' :: Point2 -> Point2 -> IM.IntMap IS.IntSet
{-# INLINE zoneOfLine' #-}
zoneOfLine' a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
    where (x,y) = zoneOfPoint a
          (x',y') = zoneOfPoint b
--zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f 
--                                 $ digitalLine (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 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 $ _cameraCenter 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 $ _cameraCenter 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 ++ [_cameraViewFrom 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 +.+ _cameraCenter 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 (fromMaybe True . (^? doorPathable)) ws

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

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

lineGeom :: Float -> Point2 -> Point2 -> [Point2]
lineGeom t x y
    | x == y    = []
    | otherwise = [x +.+ n x y, x -.- n x y, y +.+ n x y, y -.- n x y]
    where n a b      = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))

wedgeGeom :: Float -> Point2 -> Point2 -> [Point2]
wedgeGeom t x y 
    | x == y    = []
    | otherwise = [x +.+ n x y, x -.- n x y, y]
    where n a b      = (t*0.5) *.* errorNormalizeV 4200 (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

newProjectileKey :: World -> Int
newProjectileKey w = case IM.lookupMax (_projectiles 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)
                        , _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:_) -> circOnSeg x y p rad) 
                            $ fmap _wlLine $ IM.elems $ wallsNearPoint p w

crsNearLine :: Float -> [Point2] -> World -> Bool
crsNearLine d (p1:p2:_) w = any (\c -> circOnSeg 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 -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
                        $ _creatures w

crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature]
crsOnThickLine thickness p1 p2 w = IM.elems 
                        $ IM.filter (\cr -> circOnSeg 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 $ 1 - fromIntegral (levLayer l) / 100

onLayerL :: [Int] -> Picture -> Picture
onLayerL is = setDepth (1 - (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            = 74
levLayer GloomLayer         = 67
levLayer UPtLayer           = 70
levLayer PtLayer            = 72
levLayer HPtLayer           = 73
levLayer ShadowLayer        = 75   
levLayer LabelLayer         = 80
levLayer InvLayer           = 85
levLayer MenuLayer          = 90

worldPosToScreen :: World -> Point2 -> Point2
worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
  where
    doTranslate p       =   p -.- _cameraCenter w
    doZoom p            =   _cameraZoom w *.* p
    doRotate p          =   rotateV (0 - _cameraRot w) p
    doWindowScale (x,y) =   ( x * 2 / _windowX w
                            , y * 2 / _windowY w
                            )

cartePosToScreen :: World -> Point2 -> Point2
cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
  where
    doTranslate p       =   p -.- _carteCenter w
    doZoom p            =   _carteZoom w *.* p
    doRotate p          =   rotateV (0 - _carteRot w) p
    doWindowScale (x,y) =   ( x * 2 / _windowX w
                            , y * 2 / _windowY w
                            )

mouseWorldPos :: World -> Point2
mouseWorldPos w = _cameraCenter w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)

mouseCartePos :: World -> Point2
mouseCartePos w = _carteCenter w +.+ (1/_carteZoom w) *.* rotateV (_carteRot 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

mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2
mvPointTowardAtSpeed speed !ep !p 
    | dist p ep < speed = ep
    | otherwise         = p +.+ speed *.* normalizeV (ep -.- p)

mvPointToward :: Point2 -> Point2 -> Point2
mvPointToward !ep !p | dist p ep < 1 = ep
                     | otherwise     = p +.+ normalizeV (ep -.- p)