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