justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor wall points from lists to pairs

Browse Source
This commit is contained in:
jgk
2021-05-04 01:31:55 +02:00
parent e21178b688
commit 6d4c17fc07
23 changed files with 260 additions and 255 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+9 -9
View File
@@ -63,26 +63,26 @@ yourItemRef w = (creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)))
wallNormal :: Wall -> Point2
wallNormal wl = normalizeV . vNormal $ a -.- b
where
(a:b:_) = _wlLine wl
(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)
hitPoint w = intersectSegSeg' p1 p2 (fst $ _wlLine w) (snd $ _wlLine w)
hitWalls = filter (isJust . hitPoint) (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)
hitPoint w = intersectSegSeg' p1 p2 (fst $ _wlLine w) (snd $ _wlLine w)
hitWalls = filter (isJust . hitPoint) (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
f wl = circOnSeg (fst $ _wlLine wl) (snd $ _wlLine wl) p r
allWalls :: World -> IM.IntMap Wall
@@ -267,7 +267,7 @@ collideCircWalls' p1 p2 rad ws
) ws
where
f (a,_) = magV (p1 -.- a)
shiftByRad (a:b:_) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
[a +.+ rad *.* normalizeV (a -.-b)
,b +.+ rad *.* normalizeV (b -.-a)
]
@@ -284,7 +284,7 @@ collidePointWallsNorm p1 p2 ws
= listToMaybe
. sortOn f
. IM.elems
$ IM.mapMaybe (( \(x:y:_) -> intersectSegSeg' p1 p2 x y <&> (, vNormal $ x -.- y ) )
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg' p1 p2 x y <&> (, vNormal $ x -.- y ) )
. _wlLine) ws
where
f (a,_) = magV (p1 -.- a)
@@ -297,7 +297,7 @@ collidePointWallsCol p1 p2 ws
. sortOn f
. IM.elems
$ IM.mapMaybe ( (\(m, c) -> m <&> (, c))
. (\w -> (intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1), _wlColor w))) ws
. (\w -> (intersectSegSeg' p1 p2 (fst $ _wlLine w) (snd $ _wlLine w), _wlColor w))) ws
where
f (a,_) = magV (p1 -.- a)
{- | Looks for first collision of a point with walls.
@@ -312,7 +312,7 @@ collidePointWallsNormCol p1 p2 ws
where
f (a,_,_) = magV $ p1 -.- a
m w =
let (x:y:_) = _wlLine w
let (x,y) = _wlLine w
in intersectSegSeg' p1 p2 x y <&> (, vNormal (x -.- y), _wlColor w)
-- | Returns the first creature, if any, that a point intersects with.
collidePointCreatures :: Point2 -> Point2 -> World -> Maybe Int
@@ -372,7 +372,7 @@ collidePointCrsWithoutPoint cid p1 p2 w
{- | Test if a circle collides with any wall. -}
circOnSomeWall :: Point2 -> Float -> World -> Bool
circOnSomeWall p rad w
= any (\(x:y:_) -> circOnSeg x y p rad)
= any (\(x,y) -> circOnSeg x y p rad)
. fmap _wlLine
. IM.elems
$ wallsNearPoint p w
src/Dodge/Base/Collide.hs
+8 -8
View File
@@ -24,7 +24,7 @@ reflectPointWalls p1 p2 ws
. sortOn f
. IM.elems
$ IM.mapMaybe
(( \(x:y:_) ->
(( \(x,y) ->
fmap ( (, reflectIn (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
)
@@ -46,7 +46,7 @@ reflectPointWallsDamped dfact p1 p2 ws
. sortOn f
. IM.elems
$ IM.mapMaybe
(( \(x:y:_) -> fmap ((, reflectInParam dfact (x -.- y) (p2 -.- p1))
(( \(x,y) -> fmap ((, reflectInParam dfact (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 40 (vNormal (x -.- y))))
(intersectSegSeg' p1 p2 x y))
. _wlLine
@@ -56,11 +56,11 @@ reflectPointWallsDamped dfact p1 p2 ws
-- | Test if a point collides with walls
pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
pointHitsWalls p1 p2
= any $ isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine
= any $ isJust . ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine
-- | Test if there something blocking a walk
collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointWalkable p1 p2 ws
= any (isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine)
= any (isJust . ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine)
$ IM.filter (fromMaybe True . (^? doorPathable)) ws
furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
@@ -69,7 +69,7 @@ furthestPointWalkable p1 p2 ws
. listToMaybe
. sortOn (dist p1)
. IM.elems
$ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws
$ IM.mapMaybe ( ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
{-# INLINE collidePointIndirect #-}
@@ -77,7 +77,7 @@ collidePointIndirect p1 p2 ws
= listToMaybe
. sortOn (dist p1)
. IM.elems
. IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine)
. IM.mapMaybe ( ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine)
$ IM.filter (not . _wlIsSeeThrough) ws
{- | Checks to see whether someone can fire bullets effectively between two points.
- Not sure if this needs vision as well, need to make this uniform. -}
@@ -86,13 +86,13 @@ collidePointFire p1 p2 ws
= listToMaybe
. sortOn (dist p1)
. IM.elems
. IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine )
. IM.mapMaybe ( ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine )
$ IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))) ws
{- | Checks to see whether someone can fire bullets effectively between two points.
- Not sure if this needs vision as well, need to make this uniform. -}
collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointFireVision p1 p2 ws
= any ( isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine)
= any ( isJust . ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine)
$ IM.filter notBlockWindow ws
where
notBlockWindow wl = case wl ^? blHP of
src/Dodge/Data.hs
+5 -5
View File
@@ -416,14 +416,14 @@ data Either3 a b c = E3x1 a | E3x2 b | E3x3 c
data Wall
= Wall
{ _wlLine :: [Point2]
{ _wlLine :: (Point2,Point2)
, _wlID :: Int
, _wlColor :: Color
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
}
| BlockAutoDoor
{ _wlLine :: [Point2]
{ _wlLine :: (Point2,Point2)
, _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
@@ -433,17 +433,17 @@ data Wall
, _wlIsSeeThrough :: Bool
}
| Door
{ _wlLine :: [Point2]
{ _wlLine :: (Point2,Point2)
, _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
, _doorPathable :: Bool
, _drPositions :: DS.DS [Point2]
, _drPositions :: DS.DS (Point2,Point2)
}
| Block
{ _wlLine :: [Point2]
{ _wlLine :: (Point2,Point2)
, _wlID :: Int
, _wlColor :: Color
, _wlSeen :: Bool
src/Dodge/Default.hs
+6 -6
View File
@@ -27,7 +27,7 @@ import Data.Graph.Inductive.Graph hiding ((&))
import Data.List
{- Indestructible wall. -}
defaultWall = Wall
{ _wlLine = [(0,0),(50,0)]
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _wlColor = greyN 0.6
, _wlSeen = False
@@ -35,7 +35,7 @@ defaultWall = Wall
}
{- Indestructible see-through wall. -}
defaultCrystalWall = Wall
{ _wlLine = [(0,0),(50,0)]
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _wlColor = withAlpha 0.5 aquamarine
, _wlSeen = False
@@ -46,27 +46,27 @@ defaultCrystalWall = Wall
Door that opens on approach.
Pathable. -}
defaultAutoDoor = Door
{ _wlLine = [(0,0),(50,0)]
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim $ yellow
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = True
, _drPositions = DS.singleton [(0,0),(50,0)]
, _drPositions = DS.singleton ((0,0),(50,0))
}
{-
Non-pathable door.
-}
defaultDoor = Door
{ _wlLine = [(0,0),(50,0)]
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim $ yellow
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = False
, _drPositions = DS.singleton [(0,0),(50,0)]
, _drPositions = DS.singleton ((0,0),(50,0))
}
defaultCreature :: Creature
defaultCreature = Creature
src/Dodge/Event/Test.hs
+82 -80
View File
@@ -12,87 +12,89 @@ import Geometry
import qualified Data.IntMap as IM
import Control.Lens
testEvent :: World -> World
testEvent w = over walls (IM.union testWalls) w
where
k = newKey $ _walls w
setKeys = zipWith (\i wl -> wl & wlID .~ i) [k..]
testEvent w = w
testWalls = IM.fromList $ zip [k..] $ setKeys (startWalls ++ errorWalls ++ (errorWall : polyWalls) ++ endWalls)
polyPairs = makeLoopPairs
$ reverse [(-340.0,59.999996),(-374.64102,79.99999),(-340.0,100.0)]
-- [(4172.5835,2597.1892),(3855.1414,2597.1895),(3855.141,2324.7563),(4172.5835,2324.756)]
polyWalls = map (wallWithCol red . flat2) polyPairs
errorWallPair =
(9,[(-340.0,60.0),(-320.0,60.0)])
-- (48,[(3855.1414,2587.1892),(3855.141,2324.7563)])
errorWall = wallWithCol green $ snd errorWallPair
errorWallPairs =
[(1,[(-400.0,59.999996),(-340.0,60.0)])
,(12,[(-340.0,60.0),(-340.0,59.999996)])
]
-- [(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)])
-- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)])
--testEvent :: World -> World
--testEvent w = over walls (IM.union testWalls) w
-- where
-- k = newKey $ _walls w
-- setKeys = zipWith (\i wl -> wl & wlID .~ i) [k..]
--
-- testWalls = IM.fromList $ zip [k..] $ setKeys (startWalls ++ errorWalls ++ (errorWall : polyWalls) ++ endWalls)
--
-- polyPairs = makeLoopPairs
-- $ reverse [(-340.0,59.999996),(-374.64102,79.99999),(-340.0,100.0)]
---- [(4172.5835,2597.1892),(3855.1414,2597.1895),(3855.141,2324.7563),(4172.5835,2324.756)]
-- polyWalls = map (wallWithCol red . flat2) polyPairs
--
-- errorWallPair =
-- (9,[(-340.0,60.0),(-320.0,60.0)])
---- (48,[(3855.1414,2587.1892),(3855.141,2324.7563)])
-- errorWall = wallWithCol green $ snd errorWallPair
--
-- errorWallPairs =
-- [(1,[(-400.0,59.999996),(-340.0,60.0)])
-- ,(12,[(-340.0,60.0),(-340.0,59.999996)])
-- ]
errorWalls = map (wallWithCol blue . snd) errorWallPairs
startWallPairs =
[(0,[(-320.0,60.0),(-320.0,100.0)])
,(1,[(-400.0,59.999996),(-320.0,60.0)])
,(2,[(-400.0,100.0),(-400.0,59.999996)])
,(3,[(-320.0,100.0),(-400.0,100.0)])
,(4,[(-260.0,60.0),(-225.35898,80.0)])
,(5,[(-260.0,100.0),(-260.0,60.0)])
,(6,[(-225.35898,80.0),(-260.0,100.0)])
]
-- [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)])
-- ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)])
-- ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)])
-- ,(19,[(3875.1414,2552.548),(3895.1414,2587.1892)])
-- ,(32,[(3855.1414,2587.1892),(3875.1414,2552.548)])
-- ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)])
-- ,(37,[(3895.1414,2587.1892),(3895.1414,2647.1892)])
-- ,(38,[(3855.1414,2647.1892),(3855.1414,2587.1892)])
-- ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)])
-- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)])
---- [(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)])
---- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)])
---- ]
-- errorWalls = map (wallWithCol blue . snd) errorWallPairs
--
-- startWallPairs =
-- [(0,[(-320.0,60.0),(-320.0,100.0)])
-- ,(1,[(-400.0,59.999996),(-320.0,60.0)])
-- ,(2,[(-400.0,100.0),(-400.0,59.999996)])
-- ,(3,[(-320.0,100.0),(-400.0,100.0)])
-- ,(4,[(-260.0,60.0),(-225.35898,80.0)])
-- ,(5,[(-260.0,100.0),(-260.0,60.0)])
-- ,(6,[(-225.35898,80.0),(-260.0,100.0)])
-- ]
startWalls = map (wallWithCol yellow . snd) startWallPairs
endWalls = map (wallWithCol (withAlpha 0.2 orange) . snd) endWallPairs
endWallPairs =
[(0,[(-320.0,60.0),(-320.0,100.0)])
,(1,[(-400.0,59.999996),(-340.0,60.0)])
,(2,[(-400.0,100.0),(-400.0,59.999996)])
,(3,[(-320.0,100.0),(-340.0,100.0)])
,(4,[(-260.0,60.0),(-225.35898,80.0)])
,(5,[(-260.0,100.0),(-260.0,60.0)])
,(6,[(-225.35898,80.0),(-260.0,100.0)])
,(9,[(-340.0,60.0),(-320.0,60.0)])
,(11,[(-340.0,100.0),(-400.0,100.0)])
,(12,[(-340.0,60.0),(-340.0,59.999996)])
]
-- [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)])
-- ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)])
-- ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)])
-- ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)])
-- ,(38,[(3855.1414,2647.1892),(3855.1414,2598.1895)])
-- ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)])
-- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)])
-- ,(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)])
-- ,(45,[(3895.1414,2597.1895),(3895.1414,2647.1892)])
-- ,(46,[(4172.5835,2324.756),(4172.5835,2597.1892)])
-- ,(47,[(3855.141,2324.7563),(4172.5835,2324.756)])
-- ,(48,[(3855.1414,2587.1892),(3855.141,2324.7563)])
-- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)])
-- ,(50,[(3855.1414,2598.1895),(3855.1414,2597.1895)])
-- ,(51,[(4172.5835,2597.1892),(3895.1414,2597.1895)])
---- [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)])
---- ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)])
---- ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)])
---- ,(19,[(3875.1414,2552.548),(3895.1414,2587.1892)])
---- ,(32,[(3855.1414,2587.1892),(3875.1414,2552.548)])
---- ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)])
---- ,(37,[(3895.1414,2587.1892),(3895.1414,2647.1892)])
---- ,(38,[(3855.1414,2647.1892),(3855.1414,2587.1892)])
---- ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)])
---- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)])
---- ]
-- startWalls = map (wallWithCol yellow . snd) startWallPairs
--
-- endWalls = map (wallWithCol (withAlpha 0.2 orange) . snd) endWallPairs
-- endWallPairs =
-- [(0,[(-320.0,60.0),(-320.0,100.0)])
-- ,(1,[(-400.0,59.999996),(-340.0,60.0)])
-- ,(2,[(-400.0,100.0),(-400.0,59.999996)])
-- ,(3,[(-320.0,100.0),(-340.0,100.0)])
-- ,(4,[(-260.0,60.0),(-225.35898,80.0)])
-- ,(5,[(-260.0,100.0),(-260.0,60.0)])
-- ,(6,[(-225.35898,80.0),(-260.0,100.0)])
-- ,(9,[(-340.0,60.0),(-320.0,60.0)])
-- ,(11,[(-340.0,100.0),(-400.0,100.0)])
-- ,(12,[(-340.0,60.0),(-340.0,59.999996)])
-- ]
--flat2 :: (a,a) -> [a]
--flat2 (x,y) = [x,y]
wallWithCol :: Color -> [Point2] -> Wall
wallWithCol col ps = defaultWall & wlLine .~ ps & wlColor .~ col & wlSeen .~ True
---- [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)])
---- ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)])
---- ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)])
---- ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)])
---- ,(38,[(3855.1414,2647.1892),(3855.1414,2598.1895)])
---- ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)])
---- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)])
---- ,(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)])
---- ,(45,[(3895.1414,2597.1895),(3895.1414,2647.1892)])
---- ,(46,[(4172.5835,2324.756),(4172.5835,2597.1892)])
---- ,(47,[(3855.141,2324.7563),(4172.5835,2324.756)])
---- ,(48,[(3855.1414,2587.1892),(3855.141,2324.7563)])
---- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)])
---- ,(50,[(3855.1414,2598.1895),(3855.1414,2597.1895)])
---- ,(51,[(4172.5835,2597.1892),(3895.1414,2597.1895)])
---- ]
--
----flat2 :: (a,a) -> [a]
----flat2 (x,y) = [x,y]
--
--wallWithCol :: Color -> (Point2,Point2) -> Wall
--wallWithCol col ps = defaultWall & wlLine .~ ps & wlColor .~ col & wlSeen .~ True
src/Dodge/Item/Weapon/Bullet.hs
+5 -5
View File
@@ -154,7 +154,7 @@ bulHitWall' bt p x w = damageBlocks x
(a, _) = randomR (-0.1,0.1) $ _randGen w
spid = newKey $ _projectiles w
reflectDir wall = a +
argV (reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0) (p -.- sp) )
argV (reflectIn ((snd $ _wlLine wall) -.- (fst $ _wlLine wall)) (p -.- sp) )
damageBlocks wall w = case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
_ -> w
@@ -173,7 +173,7 @@ bulBounceWall' bt p wl w = damageBlocks wl $ over worldEvents addBouncer w
bouncer = (aGenBulAt' Nothing (_btColor' bt) pOut reflectVel
(_btHitEffect' bt) (_btWidth' bt)
) {_btTimer' = _btTimer' bt - 1}
wallV = _wlLine wl !! 1 -.- _wlLine wl !! 0
wallV = (snd $ _wlLine wl) -.- (fst $ _wlLine wl)
reflectVel = (reflectIn wallV (_btVel' bt))
addBouncer = (.) ( over particles (bouncer : ) )
-- the hack is to get around the fact that the particles list gets reset after
@@ -196,7 +196,7 @@ bulIncWall' bt p wl w = damageBlocks wl $ incFlamelets w
= case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
_ -> w
wallV = _wlLine wl !! 1 -.- _wlLine wl !! 0
wallV = (snd $ _wlLine wl) -.- (fst $ _wlLine wl)
reflectVel = safeNormalizeV $ reflectIn wallV (_btVel' bt)
incFlamelets = over worldEvents $ (.) (makeFlameletTimed pOut reflectVel Nothing 3 20)
@@ -215,7 +215,7 @@ bulConWall' bt p wl w = damageBlocks wl $ mkwave w
= case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
_ -> w
wallV = _wlLine wl !! 1 -.- _wlLine wl !! 0
wallV = (snd $ _wlLine wl) -.- (fst $ _wlLine wl)
mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
hvBulHitWall'
@@ -231,7 +231,7 @@ hvBulHitWall' bt p x w = damageBlocks x $ set randGen g $ foldr ($) w (sparks p
(a, g) = randomR (-0.1,0.1) $ _randGen w
spid = newKey $ _projectiles w
reflectDir wall = a +
argV (reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0) (p -.- sp) )
argV (reflectIn ((snd $ _wlLine wall) -.- (fst $ _wlLine wall)) (p -.- sp) )
sv = unitVectorAtAngle $ reflectDir x
damageBlocks wall w = case wall ^? blHP of
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 20)) w (_blIDs wall)
src/Dodge/Item/Weapon/Laser.hs
+4 -4
View File
@@ -61,7 +61,7 @@ moveLaser phaseV pos dir mcid w pt
xp = pos +.+ 800 *.* unitVectorAtAngle dir
(a,g) = randomR (-0.7,0.7) $ _randGen w
reflectDir wall = a +
(argV $ reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0) (xp -.- pos) )
(argV $ reflectIn ((fst $ _wlLine wall) -.- (snd $ _wlLine wall)) (xp -.- pos) )
(colID,_) = randomR (0,11) $ _randGen w
f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either3 Creature Wall ForceField),[Point2])
f seenWs x y = case find (h' seenWs) $ thingsHitExceptCrLongLine Nothing x y w of
@@ -76,7 +76,7 @@ moveLaser phaseV pos dir mcid w pt
h x y wl p | isEntering = p +.+ rotateV angleRef normalDist
| otherwise = p +.+ rotateV angleRef' normalDist'
where
wlNormal = vNormal $ (_wlLine wl !! 1) -.- (_wlLine wl !! 0)
wlNormal = vNormal $ (snd $ _wlLine wl) -.- (fst $ _wlLine wl)
normalDist = magV (p -.- y) *.* normalizeV wlNormal
angleInc = piRange $ argV wlNormal - argV (x -.- y)
angleRef | reflectExternal = angleInc
@@ -84,8 +84,8 @@ moveLaser phaseV pos dir mcid w pt
piRange a | a > pi = a - 2 * pi
| a > negate pi = a
| otherwise = a + 2 * pi
isEntering = isLeftOf (x -.- y) ((_wlLine wl !! 1) -.- (_wlLine wl !! 0))
wlNormal' = vNormal $ (_wlLine wl !! 0) -.- (_wlLine wl !! 1)
isEntering = isLeftOf (x -.- y) ((snd $ _wlLine wl) -.- (fst $ _wlLine wl))
wlNormal' = vNormal $ uncurry (-.-) (_wlLine wl)
normalDist' = magV (p -.- y) *.* normalizeV wlNormal'
angleInc' = piRange $ argV wlNormal' - argV (x -.- y)
angleRef' | reflectInternal = angleInc'
src/Dodge/Item/Weapon/UseEffect.hs
+3 -2
View File
@@ -99,9 +99,10 @@ mvRadar x p w pt = (putBlips w, Just $ pt {_ptDraw = const pic
putBlips = over worldEvents ((.) $ over particles ((++) blips))
blips = map (\p -> blipAt p (withAlpha (0.5*globalAlpha) red) 50)
$ circPoints
circPoints = mapMaybe (\wl -> collidePointCircCorrect (_wlLine wl !! 0) (_wlLine wl !! 1) r p)
$ (map (over wlLine reverse) $ IM.elems $ wallsAlongCirc p r w)
circPoints = mapMaybe (\wl -> collidePointCircCorrect (fst $ _wlLine wl) (snd $ _wlLine wl) r p)
$ (map (over wlLine swp) $ IM.elems $ wallsAlongCirc p r w)
++ (IM.elems $ wallsAlongCirc p r w)
swp (a,b) = (b,a)
r = fromIntegral (800 - x*16)
sweepPics = [--colHelper 0.1 $ uncurry translate p $ thickCircle r 15
--,colHelper 0.06 $ uncurry translate p $ thickCircle (r-5) 5
src/Dodge/Layout.hs
+7 -7
View File
@@ -61,12 +61,12 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts
updateWallZoning :: World -> World
updateWallZoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) w
where
wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
wallInZone wl | uncurry dist (_wlLine wl) <= 2*zoneSize
= insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
where (x,y) = zoneOfPoint $ (uncurry pHalf (_wlLine wl))
wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
makePath :: Tree Room -> [(Point2,Point2)]
@@ -84,7 +84,7 @@ wallsFromTree t =
$ (concatMap _rmPolys $ flatten t)
where
assignKeys = IM.fromList . zip [0..] . zipWith f [0..]
f i (x,y) = defaultWall {_wlLine = [x,y] , _wlID = i}
f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i}
g (x,y) = (x-3855,y - 2613)
wallsFromRooms :: [Room] -> IM.IntMap Wall
@@ -93,14 +93,14 @@ wallsFromRooms =
IM.fromList . zip [0..] . zipWith f [0..] . removeInverseWalls
. foldr cutWalls [] . concatMap _rmPolys
where
f i (x,y) = defaultWall {_wlLine = [x,y] , _wlID = i}
f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i}
divideWall :: Wall -> [Wall]
divideWall wl
= let (a:b:_) = _wlLine wl
= let (a,b) = _wlLine wl
--ps = divideLine (zoneSize * 2) a b
ps = divideLine (zoneSize * 2) a b
in map (\(x,y) -> wl {_wlLine = [x,y]}) $ zip (init ps) (tail ps)
in map (\(x,y) -> wl {_wlLine = (x,y)}) $ zip (init ps) (tail ps)
divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
divideWallIn wl wls =
src/Dodge/LevelGen.hs
+1 -1
View File
@@ -126,7 +126,7 @@ addWalls qs wl wls = foldr (addPane wl) wls pairs
pairs = zip (ps ++ [p]) (p:ps)
addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
addPane wl (p0,p1) wls = IM.insert (newKey wls) (wl
{ _wlLine = [p0,p1]
{ _wlLine = (p0,p1)
, _wlID = newKey wls
})
wls
src/Dodge/LevelGen/AutoDoor.hs
+18 -16
View File
@@ -45,13 +45,13 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr))
(lDoorClosed ++ rDoorClosed)
(map shiftL lDoorClosed ++ map shiftR rDoorClosed)
where
lDoorClosed = [ [pld,hwd]
, [hwd,hwu]
, [hwu,plu]
lDoorClosed = [ (pld,hwd)
, (hwd,hwu)
, (hwu,plu)
]
rDoorClosed = [ [pru,hwu]
, [hwu,hwd]
, [hwd,prd]
rDoorClosed = [ (pru,hwu)
, (hwu,hwd)
, (hwd,prd)
]
norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
hw = 0.5 *.* (pl +.+ pr)
@@ -62,21 +62,23 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr))
prd = pr -.- norm
hwu = hw +.+ norm
hwd = hw -.- norm
shiftL = map $ (+.+ parallel) . (-.- normalizeV parallel)
shiftR = map $ (-.- parallel) . (+.+ normalizeV parallel)
shiftL = h $ (+.+ parallel) . (-.- normalizeV parallel)
shiftR = h $ (-.- parallel) . (+.+ normalizeV parallel)
h func (x,y) = (func x,func y)
addSound (x:xs) = f x : xs
f wl = over doorMech g wl
g dm w | dist wp pld > 2 && dist wp hwd > 2
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
| otherwise = dm w
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
where
wp = snd (_wlLine $ _walls w IM.! (head xs))
autoDoorPane
:: (Point2,Point2) -- ^ Trigger line
-> Int -- ^ Wall id
-> [Point2] -- ^ Closed position
-> [Point2] -- ^ Open position
-> (Point2,Point2) -- ^ Closed position
-> (Point2,Point2) -- ^ Open position
-> Wall
autoDoorPane (trigx,trigy) n closedPos openPos = Door
{ _wlLine = closedPos
@@ -89,17 +91,17 @@ autoDoorPane (trigx,trigy) n closedPos openPos = Door
, _drPositions = DS.singleton closedPos
}
where
a = closedPos !! 0
b = closedPos !! 1
a = fst closedPos
b = snd closedPos
dm w
| any (crNearSeg 40 trigx trigy) $ IM.filter (_crIsAnimate . _crState) $ _creatures w
= flip (foldr changeZonedWall) zoneps $ over walls (IM.adjust openDoor n) w
| otherwise
= flip (foldr changeZonedWall') zoneps $ over walls (IM.adjust closeDoor n) w
mvP !ep !p = mvPointTowardAtSpeed 2 ep p
moveToward :: [Point2] -> Wall -> Wall
moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
in deepseq newPs $ w {_wlLine = newPs}
mvPs (ex,ey) (sx,sy) = (mvP ex sx,mvP ey sy)
moveToward :: (Point2,Point2) -> Wall -> Wall
moveToward (ex,ey) wls = wls & wlLine %~ mvPs (ex,ey)
openDoor = moveToward openPos
closeDoor = moveToward closedPos
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
src/Dodge/LevelGen/Block.hs
+8 -8
View File
@@ -26,7 +26,7 @@ updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) d
removeFromZone :: Wall -> World -> World
removeFromZone bl = over (wallsZone . ix x . ix y) (IM.delete (_wlID bl))
where
(x,y) = zoneOfPoint $ pHalf (_wlLine bl !! 0) (_wlLine bl !! 1)
(x,y) = zoneOfPoint $ pHalf (fst $ _wlLine bl) (snd $ _wlLine bl)
deadPanes = filter blockIsDead (IM.elems $ _walls w)
deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
blockIsDead wl = case wl ^? blHP of
@@ -38,7 +38,7 @@ killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ w
where
f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
f bl = hitSound' bl
pos = _wlLine bl !! 0
pos = fst $ _wlLine bl
hitSound bl
| _wlIsSeeThrough bl = mkSoundBreakGlass pos
| otherwise = soundMultiFrom sos soundid 25 0
@@ -50,7 +50,7 @@ killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ w
unshadow :: Int -> World -> World
unshadow bid w = case w ^? walls . ix bid of
Just b ->
let (x,y) = zoneOfPoint $ pHalf (_wlLine b !! 0) (_wlLine b !! 1)
let (x,y) = zoneOfPoint $ pHalf (fst $ _wlLine b) (snd $ _wlLine b)
in w & wallsZone . ix x . ix y . ix bid . blVisible %~ const True
& walls . ix bid . blVisible %~ const True
Nothing -> w
@@ -59,7 +59,7 @@ degradeBlock :: Wall -> World -> World
degradeBlock bl w =
let blid = _wlID bl
bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid)
ps = reverse $ orderPolygon $ nub $ concatMap _wlLine bls
ps = reverse $ orderPolygon $ nub $ concatMap ((\(a,b) -> [a,b]) . _wlLine) bls
(newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w
(x:xs) = _blDegrades bl
in addBlock newPs (x + _blHP bl) (_wlColor bl) (_wlIsSeeThrough bl) xs $ set randGen g w
@@ -104,7 +104,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w
i = newKey $ _walls w
is = [i.. i + length lines-1]
panes = IM.fromList $ zip is
$ zipWith (\j (a,b) -> Block { _wlLine = [a,b]
$ zipWith (\j (a,b) -> Block { _wlLine = (a,b)
, _wlID = j
, _wlColor = col
, _wlSeen = False
@@ -117,13 +117,13 @@ addBlock (p:ps) hp col isSeeThrough degradability w
}
) is lines
wallInZone wl
| dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
| dist (fst $ _wlLine wl) (snd $ _wlLine wl) <= 2*zoneSize
= insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
where
(x,y) = zoneOfPoint $ pHalf (_wlLine wl !! 0) (_wlLine wl !! 1)
(x,y) = zoneOfPoint $ pHalf (fst $ _wlLine wl) (snd $ _wlLine wl)
wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
ips = map zoneOfPoint $ divideLine (2*zoneSize) (fst $ _wlLine wl) (snd $ _wlLine wl)
putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
src/Dodge/LevelGen/InnerWalls.hs
+34 -34
View File
@@ -10,37 +10,37 @@ import qualified Data.IntMap as IM
------------------------------------------------------------------------------------
-- idea: create inner walls to draw and to cast shadows
createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
createInnerWalls wls = IM.map (createInnerWall wls) wls
createInnerWall :: IM.IntMap Wall -> Wall -> Wall
createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
where wl0 = _wlLine wl !! 0
wl1 = _wlLine wl !! 1
wlLeft = findWallLeft wl walls
wlRight = findWallRight wl walls
wlN = normalizeV $ vNormal $ wl1 -.- wl0
rN = normalizeV $ vNormal $ (_wlLine wlRight !! 1) -.- (_wlLine wlRight !! 0)
lN = normalizeV $ vNormal $ (_wlLine wlLeft !! 1) -.- (_wlLine wlLeft !! 0)
wlR = wl0 +.+ 20 *.* normalizeV (wlN +.+ rN)
wlL = wl1 +.+ 20 *.* normalizeV (wlN +.+ lN)
findWallLeft :: Wall -> IM.IntMap Wall -> Wall
findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
[w] -> w
wls -> error $ "findWallLeft: " ++ show (map _wlID wls)
++ " wlLines: "++ show (map _wlLine wls)
findWallRight :: Wall -> IM.IntMap Wall -> Wall
findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
[w] -> w
wls -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++
show (_wlLine wl) ++ "\nhas a right corner with and only with the walls "
++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls)
++ "\nUnless a wall has a corner with exactly one other wall, there is a problem"
findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls
findWallsRight :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
findWallsRight x wls = IM.filter (\wl -> dist x (_wlLine wl !! 1) < 1) wls
--createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
--createInnerWalls wls = IM.map (createInnerWall wls) wls
--
--createInnerWall :: IM.IntMap Wall -> Wall -> Wall
--createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
-- where wl0 = _wlLine wl !! 0
-- wl1 = _wlLine wl !! 1
-- wlLeft = findWallLeft wl walls
-- wlRight = findWallRight wl walls
-- wlN = normalizeV $ vNormal $ wl1 -.- wl0
-- rN = normalizeV $ vNormal $ (_wlLine wlRight !! 1) -.- (_wlLine wlRight !! 0)
-- lN = normalizeV $ vNormal $ (_wlLine wlLeft !! 1) -.- (_wlLine wlLeft !! 0)
-- wlR = wl0 +.+ 20 *.* normalizeV (wlN +.+ rN)
-- wlL = wl1 +.+ 20 *.* normalizeV (wlN +.+ lN)
--
--findWallLeft :: Wall -> IM.IntMap Wall -> Wall
--findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
-- [w] -> w
-- wls -> error $ "findWallLeft: " ++ show (map _wlID wls)
-- ++ " wlLines: "++ show (map _wlLine wls)
--
--findWallRight :: Wall -> IM.IntMap Wall -> Wall
--findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
-- [w] -> w
-- wls -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++
-- show (_wlLine wl) ++ "\nhas a right corner with and only with the walls "
-- ++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls)
-- ++ "\nUnless a wall has a corner with exactly one other wall, there is a problem"
--
--findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
--findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls
--
--findWallsRight :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
--findWallsRight x wls = IM.filter (\wl -> dist x (_wlLine wl !! 1) < 1) wls
src/Dodge/LevelGen/LineBlock.hs
+15 -12
View File
@@ -34,21 +34,24 @@ putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr i
blockCenPs = snd $ evenOddSplit psOnLine
numBlocks = length blockCenPs
is = [0.. numBlocks - 1]
cornerPoints = [(-halfBlockWidth,-depth) -- goes anticlockwise around the block
,(-halfBlockWidth, depth)
,( halfBlockWidth, depth)
,( halfBlockWidth,-depth)
]
cornerPoints =
[(-halfBlockWidth,-depth) -- goes anticlockwise around the block
,(-halfBlockWidth, depth)
,( halfBlockWidth, depth)
,( halfBlockWidth,-depth)
]
cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
linesAt p = map (\(a,b) -> [a,b]) $ makeLoopPairs $ cornersAt p
linesAt p = map (\(a,b) -> (a,b)) $ makeLoopPairs $ cornersAt p
k = newKey $ _walls w
ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
visibilityAt i | i == 0 = [ True,True,False,True]
| i == numBlocks - 1 = [False,True, True,True]
| otherwise = [False,True,False,True]
shadowsAt i | i == 0 = ksAtI 1
| i == numBlocks - 1 = ksAtI $ numBlocks - 2
| otherwise = ksAtI (i-1) ++ ksAtI (i+1)
visibilityAt i
| i == 0 = [ True,True,False,True]
| i == numBlocks - 1 = [False,True, True,True]
| otherwise = [False,True,False,True]
shadowsAt i
| i == 0 = ksAtI 1
| i == numBlocks - 1 = ksAtI $ numBlocks - 2
| otherwise = ksAtI (i-1) ++ ksAtI (i+1)
makeBlockAt :: Point2 -> Int -> [Wall]
makeBlockAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
makePane i visStatus k' ps
src/Dodge/LevelGen/TriggerDoor.hs
+26 -25
View File
@@ -87,12 +87,12 @@ mkTriggerDoor
mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $
transpose $ map toPanePoints ppairs
toPanePoints :: (Point2,Point2) -> [[Point2]]
toPanePoints :: (Point2,Point2) -> [(Point2,Point2)]
toPanePoints (x,y) =
[ [y +.+ perp, y -.- perp]
, [y -.- perp, x -.- perp]
, [x -.- perp, x +.+ perp]
, [x +.+ perp, y +.+ perp]
[ (y +.+ perp, y -.- perp)
, (y -.- perp, x -.- perp)
, (x -.- perp, x +.+ perp)
, (x +.+ perp, y +.+ perp)
]
where
perp = 9 *.* errorNormalizeV 49 ( vNormal (x -.- y))
@@ -104,19 +104,20 @@ mkTriggerDoubleDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPaneLinear
(map shiftLeft leftDoor ++ map shiftRight rightDoor)
where
leftDoor =
[ [pld +.+ perp,hwd]
, [hwd, hwu]
, [hwu, plu +.+ perp]
, [plu +.+ perp,pld +.+ perp]
[ (pld +.+ perp,hwd)
, (hwd, hwu)
, (hwu, plu +.+ perp)
, (plu +.+ perp,pld +.+ perp)
]
rightDoor =
[ [pru -.- perp,hwu]
, [hwu, hwd]
, [hwd, prd -.- perp]
, [prd -.- perp,pru -.- perp]
[ (pru -.- perp,hwu)
, (hwu, hwd)
, (hwd, prd -.- perp)
, (prd -.- perp,pru -.- perp)
]
shiftRight = map (+.+ (0.5 *.* (pr -.- pl)))
shiftLeft = map (+.+ (0.5 *.* (pl -.- pr)))
shiftRight = h (+.+ (0.5 *.* (pr -.- pl)))
shiftLeft = h (+.+ (0.5 *.* (pl -.- pr)))
h func (x,y) = (func x,func y)
norm = 9 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
hw = 0.5 *.* (pl +.+ pr)
perp = 5 *.* normalizeV (pl -.- pr)
@@ -133,14 +134,14 @@ mkTriggerDoubleDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPaneLinear
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
| otherwise = dm w
where
wp = _wlLine (_walls w IM.! head xs) !! 1
wp = snd $ _wlLine (_walls w IM.! head xs)
triggerDoorPaneLinear
:: Color
-> (World -> Bool) -- ^ Opening condition
-> Int -- ^ Wall id
-> [Point2] -- ^ Closed position
-> [Point2] -- ^ Open position
-> (Point2,Point2) -- ^ Closed position
-> (Point2,Point2) -- ^ Open position
-> Wall
triggerDoorPaneLinear c cond n closedPos openPos = Door
{ _wlLine = closedPos
@@ -153,8 +154,8 @@ triggerDoorPaneLinear c cond n closedPos openPos = Door
, _drPositions = DS.singleton closedPos
}
where
a = closedPos !! 0
b = closedPos !! 1
a = fst closedPos
b = snd closedPos
dm w | cond w = flip (foldr changeZonedWall) zoneps
$ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
| otherwise = flip (foldr changeZonedWall') zoneps
@@ -162,9 +163,9 @@ triggerDoorPaneLinear c cond n closedPos openPos = Door
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
mvP !ep !p = mvPointTowardAtSpeed 2 ep p
moveToward :: [Point2] -> Wall -> Wall
moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
in deepseq newPs $ w {_wlLine = newPs}
mvPs (ex,ey) (sx,sy) = (mvP ex sx,mvP ey sy)
moveToward :: (Point2,Point2) -> Wall -> Wall
moveToward (ex,ey) wls = wls & wlLine %~ mvPs (ex,ey)
openDoor = moveToward openPos
closeDoor = moveToward closedPos
changeZonedWall (!x,!y)
@@ -179,7 +180,7 @@ triggerDoorPane
:: Color
-> (World -> Bool) -- ^ Opening condition
-> Int -- ^ Wall id
-> [[Point2]] -- ^ List of positions: closed to open
-> [(Point2,Point2)] -- ^ List of positions: closed to open
-> Wall
triggerDoorPane c cond n poss = Door
{ _wlLine = head poss
@@ -205,6 +206,6 @@ triggerDoorPane c cond n poss = Door
changeZonedWall' (!x,!y)
= over wallsZone $ adjustIMZone closeDoor x y n
allZoneps = nub $ concatMap zoneps poss
zoneps [a,b]
zoneps (a,b)
| dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
src/Dodge/Render/HUD.hs
+1 -1
View File
@@ -101,7 +101,7 @@ mapWall w wl =
t = normalizeV (y -.- x)
-- n2 = 2 *.* vNormal t
n2 = 20 *.* vNormal t
(x:y:_) = _wlLine wl
(x,y) = _wlLine wl
c = _wlColor wl
{- | Pictures of popup text for items close to your position.-}
src/Dodge/Render/Picture.hs
+11 -14
View File
@@ -61,7 +61,7 @@ clDraw c = uncurry translate (_clPos c) (_clPict c c)
wallFloorsToDraw :: World -> [Wall]
wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
where
onScreen wall = lineOnScreen w (_wlLine wall)
onScreen wall = lineOnScreen w ((\(a,b) -> [a,b]) $ _wlLine wall)
isVisible wl
| wl ^? blVisible == Just False = False
| otherwise = onScreen wl
@@ -71,12 +71,12 @@ wallsOnScreen w = wallsNearZones (zoneOfScreen w) w
drawWallFloor :: Wall -> Picture
drawWallFloor wl = if _wlIsSeeThrough wl
then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y]
else blank
where
(x:y:_) = _wlLine wl
c = _wlColor wl
n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y]
else blank
where
(x,y) = _wlLine wl
c = _wlColor wl
n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
errorNormalizeVDR :: Point2 -> Point2
errorNormalizeVDR (0,0) = error "problem with function: errorNormalizeVDR in DodgeRendering"
@@ -132,7 +132,7 @@ drawWallFace w wall
| isRHS sightFrom x y || _wlIsSeeThrough wall = blank
| otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
where
(x:y:_) = _wlLine wall
(x,y) = _wlLine wall
points = extendConeToScreenEdge w sightFrom (x,y)
sightFrom = _cameraViewFrom w
@@ -195,21 +195,18 @@ drawFFShadow w ff
wallsPointsAndCols :: World -> [((Point2,Point2),Point4)]
wallsPointsAndCols w = map f . filter (not . _wlIsSeeThrough) . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
where
linePairs (x:y:_) = (x,y)
f wl = (linePairs $ _wlLine wl, _wlColor wl)
f wl = (_wlLine wl, _wlColor wl)
wallsWindows :: World -> [((Point2,Point2),Point4)]
wallsWindows w = map f . filter (fromMaybe True . (^? blVisible)) .
filter _wlIsSeeThrough . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
where
linePairs (x:y:_) = (x,y)
f wl = (linePairs $ _wlLine wl, _wlColor wl)
f wl = (_wlLine wl, _wlColor wl)
wallsForShadows :: World -> [(Point2,Point2)]
wallsForShadows w = map (linePairs . _wlLine)
wallsForShadows w = map _wlLine
. filter (not . _wlIsSeeThrough)
. IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
where linePairs (x:y:_) = (x,y)
lightsForGloom' :: World -> [Point4]
lightsForGloom' w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
src/Dodge/Room/Placement.hs
+2 -2
View File
@@ -83,7 +83,7 @@ windowLineType = PutLineBlock baseWindowPane 8 8
baseBlockPane :: Wall
baseBlockPane = Block
{ _wlLine = []
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _wlColor = greyN 0.5
, _wlSeen = False
@@ -96,7 +96,7 @@ baseBlockPane = Block
}
baseWindowPane :: Wall
baseWindowPane = Block
{ _wlLine = []
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _wlColor = withAlpha 0.2 cyan
, _wlSeen = False
src/Dodge/Update.hs
+1 -1
View File
@@ -211,7 +211,7 @@ visibleWalls p1 p2 ws
. map f
$ IM.toList ws
where
f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl))
f (i,wl) = (uncurry intersectSegSeg' (_wlLine wl) p1 p2, (i,wl))
takeUntil h xs =
let (ys,zs) = span h xs
in ys ++ tf zs
src/Dodge/WallCreatureCollisions.hs
+10 -10
View File
@@ -25,7 +25,7 @@ colCrWall w c
p1 = _crOldPos c
p2 = _crPos c
ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
wallPoints = nub $ concat ls
wallPoints = nub $ concatMap (\(x,y) -> [x,y]) ls
-- colCrPushThrough :: World -> Creature -> Creature
-- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr
@@ -41,7 +41,7 @@ wallBuffer = 3
-- the following tests whether or not a point is on a wall, and if so pushes it
-- out from the wall
-- this is then repeated if the point ends up on a new wall
collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
collideWalls :: Float -> Point2 -> [(Point2,Point2)] -> Point2 -> Point2
collideWalls rad cp1 walls cp2
= case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of
Nothing -> cp2
@@ -51,7 +51,7 @@ collideWalls rad cp1 walls cp2
-- pushes a point out from a list of walls
-- if multiple new points occur, chooses the one closest to the orignal point
pushOutFromWalls :: Float -> [[Point2]] -> Point2 -> Point2
pushOutFromWalls :: Float -> [(Point2,Point2)] -> Point2 -> Point2
pushOutFromWalls rad walls p =
fromMaybe p
. listToMaybe
@@ -59,7 +59,7 @@ pushOutFromWalls rad walls p =
$ mapMaybe (pushOutFromWall rad p)
walls
pushOrCrush :: [[Point2]] -> Creature -> Creature
pushOrCrush :: [(Point2,Point2)] -> Creature -> Creature
pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
[] -> cr
[p] -> cr & crPos .~ p
@@ -69,8 +69,8 @@ pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
-- assumes that the wall is orientated
-- assumes wall points are different
pushOutFromWall :: Float -> Point2 -> [Point2] -> Maybe (Point2)
pushOutFromWall rad cp2 (wp1:wp2:_)
pushOutFromWall :: Float -> Point2 -> (Point2,Point2) -> Maybe (Point2)
pushOutFromWall rad cp2 (wp1,wp2)
| isOnWall = Just newP -- +.+ (1 *.* norm))
| otherwise = Nothing
where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
@@ -85,7 +85,7 @@ pushOutFromCorners :: World -> Creature -> Creature
pushOutFromCorners w cr = cr & crPos .~ newPos
where
newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls
ls = nub . concat . IM.elems $ fmap _wlLine $ wallsNearPoint (_crPos cr) w
ls = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ fmap _wlLine $ wallsNearPoint (_crPos cr) w
collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2
collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps
@@ -95,12 +95,12 @@ intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
intersectCirclePoint rad p cCen | dist cCen p > rad = cCen
| otherwise = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))
checkPushThroughs :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
checkPushThroughs :: Float -> Point2 -> [(Point2,Point2)] -> Point2 -> Point2
checkPushThroughs rad cp1 walls cp2
= fromMaybe cp2 $ (listToMaybe.mapMaybe (checkPushThrough rad cp1 cp2)) walls
checkPushThrough :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2)
checkPushThrough rad cp1 cp2 (wp1:wp2:_)
checkPushThrough :: Float -> Point2 -> Point2 -> (Point2,Point2) -> Maybe (Point2)
checkPushThrough rad cp1 cp2 (wp1,wp2)
| isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2
| otherwise = Nothing
where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
src/Dodge/WorldEvent/Flash.hs
+1 -1
View File
@@ -71,7 +71,7 @@ lowLightPic len wdth col (a,b) w = case thingsHit a b w of
((p, E3x2 wall):_)
-> setCol . lineOfThickness wdth $ [alongSegBy len p wa, alongSegBy len p wb]
where x = len *.* normalizeV (wa -.- wb)
(wa:wb:_) = _wlLine wall
(wa,wb) = _wlLine wall
((p, E3x1 cr):_)
-> setCol . uncurry translate cp . rotate (-0.25 * pi + argV (p -.- cp))
$ thickArc 0 (pi/2) (_crRad cr) wdth
src/Dodge/WorldEvent/SpawnParticle.hs
+1 -2
View File
@@ -126,8 +126,7 @@ moveFlame rotd w pt
, _btVel' = reflV wl
}
pOut p = p +.+ safeNormalizeV (sp -.- p)
reflV wall = (0.3 *.* reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0)
vel )
reflV wall = (0.3 *.* reflectIn ((snd $ _wlLine wall) -.- (fst $ _wlLine wall)) vel )
+.+
(0.2 *.* vel)
smokeGen = makeFlamerSmokeAt ep
src/Dodge/WorldEvent/ThingsHit.hs
+2 -2
View File
@@ -35,7 +35,7 @@ thingsHit sp ep w
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
hitPoint w = intersectSegSeg' sp ep (fst $ _wlLine w) (snd $ _wlLine w)
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
@@ -75,7 +75,7 @@ thingsHitLongLine sp ep w
walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
hitPoint wl = intersectSegSeg' sp ep (_wlLine wl !! 0) (_wlLine wl !! 1)
hitPoint wl = intersectSegSeg' sp ep (fst $ _wlLine wl) (snd $ _wlLine wl)
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs