Refactor, try to limit dependencies
This commit is contained in:
@@ -1,15 +1,14 @@
|
||||
module Dodge.Base.CardinalPoint where
|
||||
|
||||
import Dodge.Data.Room
|
||||
import Geometry
|
||||
|
||||
cardList :: [CardinalPoint]
|
||||
cardList = [North,East,South,West]
|
||||
cardList = [North, East, South, West]
|
||||
|
||||
cardVec :: CardinalPoint -> Point2
|
||||
cardVec cp = case cp of
|
||||
North -> V2 0 1
|
||||
South -> V2 0 (-1)
|
||||
East -> V2 1 0
|
||||
West -> V2 (-1) 0
|
||||
|
||||
|
||||
North -> V2 0 1
|
||||
South -> V2 0 (-1)
|
||||
East -> V2 1 0
|
||||
West -> V2 (-1) 0
|
||||
|
||||
+176
-132
@@ -1,58 +1,58 @@
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
{- | Basic collision detection for a moving point.
|
||||
- Conventions: input is typically a stream of walls.
|
||||
- Collide returns an endpoint and maybe a collided with
|
||||
- object (wall).
|
||||
- Reflect maybe gives a slightly pushed out point from a collision and a
|
||||
- relection velocity.
|
||||
- relection velocity.
|
||||
- Overlap returns a stream of walls.
|
||||
- A point will typically be moving.
|
||||
- A ball refers to a moving circle, i.e. a point with a radius.
|
||||
- -}
|
||||
module Dodge.Base.Collide
|
||||
( collidePoint
|
||||
, collideSegCrs
|
||||
, collidePointWallsFilterStream
|
||||
, collidePointTestFilter
|
||||
, overlapSegWalls
|
||||
, overlapSegCrs
|
||||
, overlap1SegCrs
|
||||
, bounceBall
|
||||
, bouncePoint
|
||||
, sortStreamOn
|
||||
, minStreamOn
|
||||
, collideCircWallsStream
|
||||
, circOnSomeWall
|
||||
, circOnAnyCr
|
||||
, overlapCircWalls
|
||||
, overlapCircWallsClosest
|
||||
, crsNearPoint
|
||||
, allVisibleWalls
|
||||
|
||||
, hasLOS
|
||||
, hasLOSIndirect
|
||||
, hasButtonLOS
|
||||
, canSee
|
||||
, canSeeIndirect
|
||||
, isWalkable
|
||||
|
||||
, anythingHitCirc
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Zoning
|
||||
import Dodge.Base.Wall
|
||||
import Geometry
|
||||
import FoldableHelp
|
||||
-
|
||||
-}
|
||||
module Dodge.Base.Collide (
|
||||
collidePoint,
|
||||
collideSegCrs,
|
||||
collidePointWallsFilterStream,
|
||||
collidePointTestFilter,
|
||||
overlapSegWalls,
|
||||
overlapSegCrs,
|
||||
overlap1SegCrs,
|
||||
bounceBall,
|
||||
bouncePoint,
|
||||
sortStreamOn,
|
||||
minStreamOn,
|
||||
collideCircWallsStream,
|
||||
circOnSomeWall,
|
||||
circOnAnyCr,
|
||||
overlapCircWalls,
|
||||
overlapCircWallsClosest,
|
||||
crsNearPoint,
|
||||
allVisibleWalls,
|
||||
hasLOS,
|
||||
hasLOSIndirect,
|
||||
hasButtonLOS,
|
||||
canSee,
|
||||
canSeeIndirect,
|
||||
isWalkable,
|
||||
anythingHitCirc,
|
||||
) where
|
||||
|
||||
import Control.Lens
|
||||
import qualified Data.IntSet as IS
|
||||
import Data.List (sortOn)
|
||||
import Data.Maybe
|
||||
import Dodge.Base.Wall
|
||||
import Dodge.Data.World
|
||||
import Dodge.Zoning
|
||||
import FoldableHelp
|
||||
import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
import Control.Lens
|
||||
import StreamingHelp
|
||||
import qualified Streaming.Prelude as S
|
||||
import qualified Data.IntSet as IS
|
||||
import StreamingHelp
|
||||
|
||||
--collidePoint :: Point2 -> Point2
|
||||
--collidePoint :: Point2 -> Point2
|
||||
-- -> StreamOf Wall
|
||||
-- -> (Point2, Maybe Wall)
|
||||
--{-# INLINE collidePoint #-}
|
||||
@@ -60,54 +60,69 @@ import qualified Data.IntSet as IS
|
||||
-- where
|
||||
-- findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
|
||||
|
||||
collidePoint :: Point2 -> Point2
|
||||
-> [Wall]
|
||||
-> (Point2, Maybe Wall)
|
||||
collidePoint ::
|
||||
Point2 ->
|
||||
Point2 ->
|
||||
[Wall] ->
|
||||
(Point2, Maybe Wall)
|
||||
{-# INLINE collidePoint #-}
|
||||
collidePoint sp ep = foldl' findPoint (ep, Nothing)
|
||||
where
|
||||
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
|
||||
findPoint (p, mwl) wl = maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl
|
||||
|
||||
overlap1SegCrs :: Point2 -> Point2
|
||||
-> [Creature]
|
||||
-> [(Point2, Creature)]
|
||||
overlap1SegCrs ::
|
||||
Point2 ->
|
||||
Point2 ->
|
||||
[Creature] ->
|
||||
[(Point2, Creature)]
|
||||
{-# INLINE overlap1SegCrs #-}
|
||||
overlap1SegCrs sp ep = mapMaybe
|
||||
(\cr -> (,cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep ))
|
||||
overlap1SegCrs sp ep =
|
||||
mapMaybe
|
||||
(\cr -> (,cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
|
||||
|
||||
overlapSegCrs :: Point2 -> Point2
|
||||
-> StreamOf Creature
|
||||
-> StreamOf ([Point2], Creature)
|
||||
overlapSegCrs ::
|
||||
Point2 ->
|
||||
Point2 ->
|
||||
StreamOf Creature ->
|
||||
StreamOf ([Point2], Creature)
|
||||
{-# INLINE overlapSegCrs #-}
|
||||
overlapSegCrs sp ep = S.mapMaybe
|
||||
(\cr -> f cr $ intersectCircSeg (_crPos cr) (_crRad cr) sp ep )
|
||||
overlapSegCrs sp ep =
|
||||
S.mapMaybe
|
||||
(\cr -> f cr $ intersectCircSeg (_crPos cr) (_crRad cr) sp ep)
|
||||
where
|
||||
f _ [] = Nothing
|
||||
f cr ps = Just (ps,cr)
|
||||
f _ [] = Nothing
|
||||
f cr ps = Just (ps, cr)
|
||||
|
||||
collideSegCrs :: Point2 -> Point2
|
||||
-> StreamOf Creature
|
||||
-> (Point2, Maybe Creature)
|
||||
collideSegCrs ::
|
||||
Point2 ->
|
||||
Point2 ->
|
||||
StreamOf Creature ->
|
||||
(Point2, Maybe Creature)
|
||||
{-# INLINE collideSegCrs #-}
|
||||
collideSegCrs sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id
|
||||
where
|
||||
findPoint (p,mcr) cr
|
||||
= maybe (p,mcr) (,Just cr) $ listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp p)
|
||||
findPoint (p, mcr) cr =
|
||||
maybe (p, mcr) (,Just cr) $ listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp p)
|
||||
|
||||
doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2)
|
||||
{-# INLINE doBounce #-}
|
||||
doBounce x sp ep (p, mwl) = mwl <&> \wl ->
|
||||
( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
|
||||
, reflVelWallDamp x wl (ep -.- sp)
|
||||
)
|
||||
doBounce x sp ep (p, mwl) =
|
||||
mwl <&> \wl ->
|
||||
( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl)))
|
||||
, reflVelWallDamp x wl (ep -.- sp)
|
||||
)
|
||||
|
||||
bounceBall :: Float -> Point2 -> Point2 -> Float
|
||||
-> [Wall]
|
||||
-> Maybe (Point2,Point2)
|
||||
bounceBall ::
|
||||
Float ->
|
||||
Point2 ->
|
||||
Point2 ->
|
||||
Float ->
|
||||
[Wall] ->
|
||||
Maybe (Point2, Point2)
|
||||
{-# INLINE bounceBall #-}
|
||||
bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r
|
||||
|
||||
bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2)
|
||||
bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2, Point2)
|
||||
{-# INLINE bouncePoint #-}
|
||||
bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep
|
||||
|
||||
@@ -115,39 +130,41 @@ bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep
|
||||
-- whether this is actually faster
|
||||
collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> [Wall] -> Bool
|
||||
{-# INLINE collidePointTestFilter #-}
|
||||
collidePointTestFilter t sp ep
|
||||
= any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
|
||||
. filter t
|
||||
collidePointTestFilter t sp ep =
|
||||
any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
|
||||
. filter t
|
||||
|
||||
---- this COULD be written in terms of collidePointWallsFilterStream, TODO test
|
||||
---- whether this is actually faster
|
||||
--collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool
|
||||
--{-# INLINE collidePointTestFilter #-}
|
||||
--collidePointTestFilter t sp ep = runIdentity
|
||||
--collidePointTestFilter t sp ep = runIdentity
|
||||
-- . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine)
|
||||
-- . S.filter t
|
||||
|
||||
collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall)
|
||||
{-# INLINE collidePointWallsFilterStream #-}
|
||||
collidePointWallsFilterStream t sp ep = collidePoint sp ep
|
||||
. filter t
|
||||
. wlsNearSeg sp ep
|
||||
collidePointWallsFilterStream t sp ep =
|
||||
collidePoint sp ep
|
||||
. filter t
|
||||
. wlsNearSeg sp ep
|
||||
|
||||
--overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall
|
||||
-- -> StreamOf (Point2,Wall)
|
||||
--{-# INLINE overlapSegWalls #-}
|
||||
--overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
|
||||
|
||||
overlapSegWalls :: Point2 -> Point2 -> [Wall] -> [(Point2,Wall)]
|
||||
overlapSegWalls :: Point2 -> Point2 -> [Wall] -> [(Point2, Wall)]
|
||||
{-# INLINE overlapSegWalls #-}
|
||||
overlapSegWalls sp ep = mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl)
|
||||
|
||||
visibleWalls :: Point2 -> Point2 -> World -> [(Point2,Wall)]
|
||||
visibleWalls :: Point2 -> Point2 -> World -> [(Point2, Wall)]
|
||||
{-# INLINE visibleWalls #-}
|
||||
visibleWalls sp ep = takeUntil (not . wlIsOpaque . snd)
|
||||
. sortOn (dist sp . fst)
|
||||
. overlapSegWalls sp ep
|
||||
. wlsNearSeg sp ep
|
||||
visibleWalls sp ep =
|
||||
takeUntil (not . wlIsOpaque . snd)
|
||||
. sortOn (dist sp . fst)
|
||||
. overlapSegWalls sp ep
|
||||
. wlsNearSeg sp ep
|
||||
|
||||
--visibleWalls :: Point2 -> Point2 -> World -> StreamOf (Point2,Wall)
|
||||
--{-# INLINE visibleWalls #-}
|
||||
@@ -157,7 +174,7 @@ visibleWalls sp ep = takeUntil (not . wlIsOpaque . snd)
|
||||
-- . overlapSegWalls sp ep
|
||||
-- . wlsNearSeg sp ep )
|
||||
|
||||
allVisibleWalls :: World -> [(Point2,Wall)]
|
||||
allVisibleWalls :: World -> [(Point2, Wall)]
|
||||
{-# INLINE allVisibleWalls #-}
|
||||
allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays 20
|
||||
where
|
||||
@@ -168,7 +185,7 @@ allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays
|
||||
--allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20)
|
||||
-- where
|
||||
-- vPos = _cameraViewFrom w
|
||||
|
||||
|
||||
--overlapCircWalls :: Point2 -> Float -> StreamOf Wall
|
||||
-- -> StreamOf (Point2,Wall)
|
||||
--{-# INLINE overlapCircWalls #-}
|
||||
@@ -177,61 +194,81 @@ allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays
|
||||
-- dointersect wl = f (_wlLine wl) <&> (,wl)
|
||||
-- f (a,b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
|
||||
|
||||
overlapCircWalls :: Point2 -> Float -> [Wall]
|
||||
-> [(Point2,Wall)]
|
||||
overlapCircWalls ::
|
||||
Point2 ->
|
||||
Float ->
|
||||
[Wall] ->
|
||||
[(Point2, Wall)]
|
||||
{-# INLINE overlapCircWalls #-}
|
||||
overlapCircWalls p r = mapMaybe dointersect
|
||||
where
|
||||
dointersect wl = f (_wlLine wl) <&> (,wl)
|
||||
f (a,b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
|
||||
f (a, b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b
|
||||
|
||||
-- | note that this does not push the circle away from the wall at all
|
||||
collideCircWalls :: Point2 -> Point2 -> Float -> [Wall] -> (Point2, Maybe Wall)
|
||||
{-# INLINE collideCircWalls #-}
|
||||
collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing)
|
||||
where
|
||||
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
|
||||
. shiftbyrad
|
||||
. _wlLine $ wl
|
||||
shiftbyrad (a,b) = bimap f f
|
||||
(a +.+ rad *.* normalizeV (a -.-b)
|
||||
,b +.+ rad *.* normalizeV (b -.-a)
|
||||
)
|
||||
findPoint (p, mwl) wl =
|
||||
maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
|
||||
. shiftbyrad
|
||||
. _wlLine
|
||||
$ wl
|
||||
shiftbyrad (a, b) =
|
||||
bimap
|
||||
f
|
||||
f
|
||||
( a +.+ rad *.* normalizeV (a -.- b)
|
||||
, b +.+ rad *.* normalizeV (b -.- a)
|
||||
)
|
||||
where
|
||||
f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
|
||||
|
||||
-- | note that this does not push the circle away from the wall at all
|
||||
collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall
|
||||
-> (Point2, Maybe Wall)
|
||||
collideCircWallsStream ::
|
||||
Point2 ->
|
||||
Point2 ->
|
||||
Float ->
|
||||
StreamOf Wall ->
|
||||
(Point2, Maybe Wall)
|
||||
{-# INLINE collideCircWallsStream #-}
|
||||
collideCircWallsStream sp ep rad = runIdentity . S.fold_ findPoint (ep, Nothing) id
|
||||
where
|
||||
findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
|
||||
. shiftbyrad
|
||||
. _wlLine $ wl
|
||||
shiftbyrad (a,b) = bimap f f
|
||||
(a +.+ rad *.* normalizeV (a -.-b)
|
||||
,b +.+ rad *.* normalizeV (b -.-a)
|
||||
)
|
||||
findPoint (p, mwl) wl =
|
||||
maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p)
|
||||
. shiftbyrad
|
||||
. _wlLine
|
||||
$ wl
|
||||
shiftbyrad (a, b) =
|
||||
bimap
|
||||
f
|
||||
f
|
||||
( a +.+ rad *.* normalizeV (a -.- b)
|
||||
, b +.+ rad *.* normalizeV (b -.- a)
|
||||
)
|
||||
where
|
||||
f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b))
|
||||
|
||||
overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2,Wall)
|
||||
overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2, Wall)
|
||||
{-# INLINE overlapCircWallsClosest #-}
|
||||
overlapCircWallsClosest p r = safeMinimumOn (dist p . fst)
|
||||
. overlapCircWalls p r
|
||||
overlapCircWallsClosest p r =
|
||||
safeMinimumOn (dist p . fst)
|
||||
. overlapCircWalls p r
|
||||
|
||||
--overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall)
|
||||
--{-# INLINE overlapCircWallsClosest #-}
|
||||
--overlapCircWallsClosest p r = minStreamOn (dist p . fst)
|
||||
-- . overlapCircWalls p r
|
||||
|
||||
{- | Test if a circle collides with any wall.
|
||||
- Note no check on whether the wall is walkable. -}
|
||||
{- | Test if a circle collides with any wall.
|
||||
- Note no check on whether the wall is walkable.
|
||||
-}
|
||||
circOnSomeWall :: Point2 -> Float -> World -> Bool
|
||||
{-# INLINE circOnSomeWall #-}
|
||||
circOnSomeWall p rad = any (uncurry (circOnSeg p rad) . _wlLine)
|
||||
. wlsNearPoint p
|
||||
circOnSomeWall p rad =
|
||||
any (uncurry (circOnSeg p rad) . _wlLine)
|
||||
. wlsNearPoint p
|
||||
|
||||
--circOnSomeWall :: Point2 -> Float -> World -> Bool
|
||||
--{-# INLINE circOnSomeWall #-}
|
||||
@@ -244,53 +281,60 @@ circOnAnyCr p r w = IS.foldr f False $ crIXsNearPoint p w
|
||||
where
|
||||
f cid bl = maybe False (\cr -> dist p (_crPos cr) < r + _crRad cr) (w ^? cWorld . creatures . ix cid) || bl
|
||||
|
||||
{- | More general collision tests follow -}
|
||||
|
||||
-- | More general collision tests follow
|
||||
hasLOS :: Point2 -> Point2 -> World -> Bool
|
||||
{-# INLINE hasLOS #-}
|
||||
hasLOS p1 p2 = not
|
||||
. collidePointTestFilter (const True) p1 p2
|
||||
. wlsNearSeg p1 p2
|
||||
hasLOS p1 p2 =
|
||||
not
|
||||
. collidePointTestFilter (const True) p1 p2
|
||||
. wlsNearSeg p1 p2
|
||||
|
||||
hasButtonLOS :: Point2 -> Point2 -> World -> Bool
|
||||
{-# INLINE hasButtonLOS #-}
|
||||
hasButtonLOS p1 p2 = not
|
||||
. collidePointTestFilter (not . _wlTouchThrough) p1 p2
|
||||
. wlsNearSeg p1 p2
|
||||
hasButtonLOS p1 p2 =
|
||||
not
|
||||
. collidePointTestFilter (not . _wlTouchThrough) p1 p2
|
||||
. wlsNearSeg p1 p2
|
||||
|
||||
hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
|
||||
{-# INLINE hasLOSIndirect #-}
|
||||
hasLOSIndirect p1 p2 = not
|
||||
. collidePointTestFilter wlIsOpaque p1 p2
|
||||
. wlsNearSeg p1 p2
|
||||
hasLOSIndirect p1 p2 =
|
||||
not
|
||||
. collidePointTestFilter wlIsOpaque p1 p2
|
||||
. wlsNearSeg p1 p2
|
||||
|
||||
isWalkable :: Point2 -> Point2 -> World -> Bool
|
||||
{-# INLINE isWalkable #-}
|
||||
isWalkable p1 p2 = not
|
||||
. collidePointTestFilter (not . (^?! wlPathable)) p1 p2
|
||||
. wlsNearSeg p1 p2
|
||||
isWalkable p1 p2 =
|
||||
not
|
||||
. collidePointTestFilter (not . (^?! wlPathable)) p1 p2
|
||||
. wlsNearSeg p1 p2
|
||||
|
||||
canSee :: Int -> Int -> World -> Bool
|
||||
{-# INLINE canSee #-}
|
||||
canSee i j w = hasLOS p1 p2 w
|
||||
where
|
||||
where
|
||||
p1 = _crPos (_creatures (_cWorld w) IM.! i)
|
||||
p2 = _crPos (_creatures (_cWorld w) IM.! j) -- unsafe
|
||||
p2 = _crPos (_creatures (_cWorld w) IM.! j) -- unsafe
|
||||
|
||||
canSeeIndirect :: Int -> Int -> World -> Bool
|
||||
{-# INLINE canSeeIndirect #-}
|
||||
canSeeIndirect i j w = hasLOSIndirect ipos jpos w
|
||||
where
|
||||
where
|
||||
ipos = _crPos (_creatures (_cWorld w) IM.! i)
|
||||
jpos = _crPos (_creatures (_cWorld w) IM.! j)
|
||||
|
||||
anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool
|
||||
anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl)
|
||||
where
|
||||
hitCr = IS.foldr f False $ crsNearSeg sp ep w
|
||||
f cid bl = maybe False (\cr -> null $ intersectCircSeg (_crPos cr) (rad + _crRad cr) sp ep)
|
||||
hitCr = IS.foldr f False $ crsNearSeg sp ep w
|
||||
f cid bl =
|
||||
maybe
|
||||
False
|
||||
(\cr -> null $ intersectCircSeg (_crPos cr) (rad + _crRad cr) sp ep)
|
||||
(w ^? cWorld . creatures . ix cid)
|
||||
|| bl
|
||||
|| bl
|
||||
|
||||
hitWl = collideCircWalls sp ep rad $ wlsNearPoint ep w
|
||||
-- this should probably be wallsOnLine or something
|
||||
hitWl = collideCircWalls sp ep rad $ wlsNearPoint ep w
|
||||
|
||||
-- this should probably be wallsOnLine or something
|
||||
|
||||
@@ -1,38 +1,48 @@
|
||||
module Dodge.Base.Coordinate where
|
||||
import Dodge.Data
|
||||
import Dodge.Base.WinScale
|
||||
|
||||
import Dodge.Base.WinScale
|
||||
import Dodge.Data.Universe
|
||||
import Geometry
|
||||
{- | Transform coordinates from world position to screen coordinates. -}
|
||||
|
||||
-- | Transform coordinates from world position to screen coordinates.
|
||||
worldPosToScreenNorm :: Configuration -> World -> Point2 -> Point2
|
||||
worldPosToScreenNorm cfig w = doWindowScale cfig . doRotate . doZoom . doTranslate
|
||||
where
|
||||
doTranslate p = p -.- _cameraCenter (_cWorld w)
|
||||
doZoom p = _cameraZoom (_cWorld w) *.* p
|
||||
doRotate p = rotateV (negate $ _cameraRot (_cWorld w)) p
|
||||
{- | Transform world coordinates to scaled screen coordinates.
|
||||
doZoom p = _cameraZoom (_cWorld w) *.* p
|
||||
doRotate p = rotateV (negate $ _cameraRot (_cWorld w)) p
|
||||
|
||||
{- | Transform world coordinates to scaled screen coordinates.
|
||||
- These have to be scaled according to the size of the window to get actual screen positions.
|
||||
- This allows for line thicknesses etc to correspond to pixel sizes.-}
|
||||
- This allows for line thicknesses etc to correspond to pixel sizes.
|
||||
-}
|
||||
worldPosToScreen :: World -> Point2 -> Point2
|
||||
worldPosToScreen w
|
||||
= rotateV (negate $ _cameraRot (_cWorld w))
|
||||
. (_cameraZoom (_cWorld w) *.*)
|
||||
. (-.- _cameraCenter (_cWorld w))
|
||||
worldPosToScreen w =
|
||||
rotateV (negate $ _cameraRot (_cWorld w))
|
||||
. (_cameraZoom (_cWorld w) *.*)
|
||||
. (-.- _cameraCenter (_cWorld w))
|
||||
|
||||
{- | Transform coordinates from the map position to screen
|
||||
coordinates. -}
|
||||
coordinates.
|
||||
-}
|
||||
cartePosToScreen :: Configuration -> World -> Point2 -> Point2
|
||||
cartePosToScreen cfig w = doWindowScale cfig . doRotate . doZoom . doTranslate
|
||||
where
|
||||
doTranslate p = p -.- _carteCenter (_hud (_cWorld w))
|
||||
doZoom p = _carteZoom (_hud (_cWorld w)) *.* p
|
||||
doRotate p = rotateV (negate $ _carteRot (_hud (_cWorld w))) p
|
||||
crToMousePosOffset :: Creature -> World -> (Point2,Float)
|
||||
crToMousePosOffset cr w = (mouseWorldPos w -.- _crPos cr,0)
|
||||
{- | The mouse position in world coordinates. -}
|
||||
doTranslate p = p -.- _carteCenter (_hud (_cWorld w))
|
||||
doZoom p = _carteZoom (_hud (_cWorld w)) *.* p
|
||||
doRotate p = rotateV (negate $ _carteRot (_hud (_cWorld w))) p
|
||||
|
||||
crToMousePosOffset :: Creature -> World -> (Point2, Float)
|
||||
crToMousePosOffset cr w = (mouseWorldPos w -.- _crPos cr, 0)
|
||||
|
||||
-- | The mouse position in world coordinates.
|
||||
mouseWorldPos :: World -> Point2
|
||||
mouseWorldPos w = _cameraCenter (_cWorld w) +.+
|
||||
(1/_cameraZoom (_cWorld w)) *.* rotateV (_cameraRot (_cWorld w)) (_mousePos w)
|
||||
{- | The mouse position in map coordinates -}
|
||||
mouseWorldPos w =
|
||||
_cameraCenter (_cWorld w)
|
||||
+.+ (1 / _cameraZoom (_cWorld w)) *.* rotateV (_cameraRot (_cWorld w)) (_mousePos w)
|
||||
|
||||
-- | The mouse position in map coordinates
|
||||
mouseCartePos :: World -> Point2
|
||||
mouseCartePos w = _carteCenter (_hud (_cWorld w)) +.+
|
||||
(1/_carteZoom (_hud (_cWorld w))) *.* rotateV (_carteRot (_hud (_cWorld w))) (_mousePos w)
|
||||
mouseCartePos w =
|
||||
_carteCenter (_hud (_cWorld w))
|
||||
+.+ (1 / _carteZoom (_hud (_cWorld w))) *.* rotateV (_carteRot (_hud (_cWorld w))) (_mousePos w)
|
||||
|
||||
@@ -1,27 +0,0 @@
|
||||
module Dodge.Base.Item
|
||||
(
|
||||
) where
|
||||
--import Dodge.Data
|
||||
--import Dodge.Base.You
|
||||
--import LensHelp
|
||||
--
|
||||
--import qualified IntMapHelp as IM
|
||||
|
||||
--selectedObject :: World -> Maybe (Either FloorItem Button)
|
||||
--selectedObject w = lookup (_crInvSel ycr) $ zip [n..] $ _closeObjects w
|
||||
-- where
|
||||
-- ycr = you w
|
||||
-- n = length $ _crInv ycr
|
||||
--
|
||||
--crItem :: World -> Int -> Item
|
||||
--crItem w cid = _crInv cr IM.! _crInvSel cr
|
||||
-- where
|
||||
-- cr = _creatures w IM.! cid
|
||||
--
|
||||
--yourItemRef
|
||||
-- :: Applicative f
|
||||
-- => World
|
||||
-- -> (Item -> f Item)
|
||||
-- -> World
|
||||
-- -> f World
|
||||
--yourItemRef w = creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))
|
||||
@@ -1,5 +1,6 @@
|
||||
module Dodge.Base.Wall where
|
||||
import Dodge.Data
|
||||
|
||||
import Dodge.Data.Wall
|
||||
import Geometry
|
||||
|
||||
wlIsOpaque :: Wall -> Bool
|
||||
|
||||
+41
-34
@@ -1,54 +1,61 @@
|
||||
{- | Getting the window size geometry. -}
|
||||
module Dodge.Base.Window
|
||||
( halfWidth
|
||||
, halfHeight
|
||||
, screenPolygon
|
||||
, screenPolygonBord
|
||||
, screenBox
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
-- | Getting the window size geometry.
|
||||
module Dodge.Base.Window (
|
||||
halfWidth,
|
||||
halfHeight,
|
||||
screenPolygon,
|
||||
screenPolygonBord,
|
||||
screenBox,
|
||||
) where
|
||||
|
||||
import Dodge.Data.Universe
|
||||
import Geometry
|
||||
|
||||
-- | A box covering the screen in world coordinates
|
||||
screenPolygon :: Configuration -> World -> [Point2]
|
||||
screenPolygon cfig w = map (scTran . scRot . scZoom) $ screenBox cfig
|
||||
-- [tr,tl,bl,br]
|
||||
where
|
||||
scRot = rotateV (_cameraRot (_cWorld w))
|
||||
scZoom p | _cameraZoom (_cWorld w) /= 0 = (1/_cameraZoom (_cWorld w)) *.* p
|
||||
| otherwise = p
|
||||
where
|
||||
-- [tr,tl,bl,br]
|
||||
|
||||
scRot = rotateV (_cameraRot (_cWorld w))
|
||||
scZoom p
|
||||
| _cameraZoom (_cWorld w) /= 0 = (1 / _cameraZoom (_cWorld w)) *.* p
|
||||
| otherwise = p
|
||||
scTran p = p +.+ _cameraCenter (_cWorld w)
|
||||
-- tr = scTran $ scRot $ scZoom (V2 ( halfWidth w) ( halfHeight w))
|
||||
-- tl = scTran $ scRot $ scZoom (V2 (-halfWidth w) ( halfHeight w))
|
||||
|
||||
-- tr = scTran $ scRot $ scZoom (V2 ( halfWidth w) ( halfHeight w))
|
||||
-- tl = scTran $ scRot $ scZoom (V2 (-halfWidth w) ( halfHeight w))
|
||||
-- br = scTran $ scRot $ scZoom (V2 ( halfWidth w) (-halfHeight w))
|
||||
-- bl = scTran $ scRot $ scZoom (V2 (-halfWidth w) (-halfHeight w))
|
||||
|
||||
-- | A box covering the screen in world coordinates, with a x and y border
|
||||
screenPolygonBord
|
||||
:: Float -- ^ X border
|
||||
-> Float -- ^ Y border
|
||||
-> Configuration
|
||||
-> World
|
||||
-> [Point2]
|
||||
screenPolygonBord xbord ybord cfig w = [tr,tl,bl,br]
|
||||
where
|
||||
hw = halfWidth cfig - xbord
|
||||
screenPolygonBord ::
|
||||
-- | X border
|
||||
Float ->
|
||||
-- | Y border
|
||||
Float ->
|
||||
Configuration ->
|
||||
World ->
|
||||
[Point2]
|
||||
screenPolygonBord xbord ybord cfig w = [tr, tl, bl, br]
|
||||
where
|
||||
hw = halfWidth cfig - xbord
|
||||
hh = halfHeight cfig - ybord
|
||||
scZoom p | _cameraZoom (_cWorld w) /= 0 = (1/_cameraZoom (_cWorld w)) *.* p
|
||||
| otherwise = p
|
||||
scZoom p
|
||||
| _cameraZoom (_cWorld w) /= 0 = (1 / _cameraZoom (_cWorld w)) *.* p
|
||||
| otherwise = p
|
||||
theTransform = (+.+ _cameraCenter (_cWorld w)) . rotateV (_cameraRot (_cWorld w)) . scZoom
|
||||
tr = theTransform (V2 hw hh )
|
||||
tl = theTransform (V2 (-hw) hh )
|
||||
br = theTransform (V2 hw (-hh))
|
||||
bl = theTransform (V2 (-hw) (-hh))
|
||||
tr = theTransform (V2 hw hh)
|
||||
tl = theTransform (V2 (- hw) hh)
|
||||
br = theTransform (V2 hw (- hh))
|
||||
bl = theTransform (V2 (- hw) (- hh))
|
||||
|
||||
halfWidth,halfHeight :: Configuration -> Float
|
||||
halfWidth, halfHeight :: Configuration -> Float
|
||||
halfWidth w = _windowX w / 2
|
||||
halfHeight w = _windowY w / 2
|
||||
|
||||
-- | A box of the size of the screen in screen centered coordinates
|
||||
screenBox :: Configuration -> [Point2]
|
||||
screenBox w = rectNSWE hh (-hh) (-hw) hw
|
||||
screenBox w = rectNSWE hh (- hh) (- hw) hw
|
||||
where
|
||||
hw = halfWidth w
|
||||
hh = halfHeight w
|
||||
|
||||
@@ -1,8 +1,7 @@
|
||||
module Dodge.Base.You where
|
||||
import Dodge.Data
|
||||
--import Picture
|
||||
|
||||
import Dodge.Data.World
|
||||
import qualified IntMapHelp as IM
|
||||
--import Control.Lens
|
||||
|
||||
you :: World -> Creature
|
||||
you w = _creatures (_cWorld w) IM.! _yourID (_cWorld w)
|
||||
|
||||
Reference in New Issue
Block a user