780 lines
34 KiB
Haskell
780 lines
34 KiB
Haskell
--{-# 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 = 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 = 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 (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' :: 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 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 ++ [_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 +.+ _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 (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:_) -> 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 $ 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 -.- _cameraPos 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 - _cameraRot w) p
|
|
doWindowScale (x,y) = ( x * 2 / _windowX w
|
|
, y * 2 / _windowY w
|
|
)
|
|
|
|
mouseWorldPos :: World -> Point2
|
|
mouseWorldPos w = _cameraPos 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)
|
|
|