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

Merge branch 'master' of ssh://git.xkjq.uk:30001/justin/loop

Browse Source
This commit is contained in:
Ross
2021-04-05 22:47:47 +01:00
parent b75c24e384 654479da36
commit 76dfe01442
23 changed files with 492 additions and 273 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/AIs.hs
+13 -13
View File
@@ -415,8 +415,8 @@ chaseAI w (f,g') cr =
---- $ mvForward 2.5 cid $ randomTurn $ turnTowardSpeed 0.05 p cid w
---- | dist p cpos < 10 -> replaceAction [] w
---- | x == 0 -> replaceAction [] w
---- -- | not (canSeePoint cid p w) -> replaceAction [PathTo p] w
---- -- | not (canSeePoint cid p w) -> replaceAction [] w
---- -- | not (canSeePoint cid p w) -> replaceAction [PathTo p] w
---- -- | not (canSeePoint cid p w) -> replaceAction [] w
---- | angleVV (unitVectorAtAngle (_crDir cr)) (p -.- cpos) > pi/4
---- -> replaceAction [MoveToFor p (max 0 (x-1))] $ turnTowardSpeed 0.05 p cid w
---- | otherwise -> replaceAction [MoveToFor p (max 0 (x-1))]
@@ -526,7 +526,7 @@ miniAI w (f,g) cr =
-> ( (f , g)
, Just $ turnCloseSlow ypos cr
) -- no longer chase if see you when reloading
-- $ replaceAction [] w
-- $ replaceAction [] w
| otherwise -> ( (f , g) , Just cr)
(Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr)
| otherwise
@@ -646,7 +646,7 @@ strafeOrChargeAI inRange outRange w (f,g) cr =
-> ( (f , g)
, Just $ strafeCloseSlow ypos cr
) -- no longer chase if see you when reloading
-- $ replaceAction [] w
-- $ replaceAction [] w
| otherwise -> ( (f , g) , Just cr)
(Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr)
| otherwise
@@ -825,8 +825,8 @@ launcherAI inRange outRange w (f,g) cr =
| otherwise = 0
curveLeftProb = 20
curveRightProb = 20
-- | dist cpos ypos < 200 = 1
-- | otherwise = 0
-- | dist cpos ypos < 200 = 1
-- | otherwise = 0
fireActions = -- TurnToward ypos :
(evalState (takeOneWeighted
[curveLeftProb,curveRightProb
@@ -921,7 +921,7 @@ launcherAI inRange outRange w (f,g) cr =
-> ( (f , g')
, Just $ cr
) -- no longer chase if see you when reloading
-- $ replaceAction [] w
-- $ replaceAction [] w
| otherwise -> ( (f , g') , Just cr)
(Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w
-> ( ( f , g')
@@ -1161,7 +1161,7 @@ circleClockwiseAI inRange outRange w (f,g) cr =
-> ( (f , g)
, Just $ strafeCloseSlow ypos cr
) -- no longer chase if see you when reloading
-- $ replaceAction [] w
-- $ replaceAction [] w
| otherwise -> ( (f , g) , Just cr)
(Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr)
| otherwise
@@ -1269,7 +1269,7 @@ twitchMissAI inRange outRange w (f,g) cr =
-> ( (f , g')
, Just $ strafeCloseSlow ypos cr
) -- no longer chase if see you when reloading
-- $ replaceAction [] w
-- $ replaceAction [] w
| otherwise -> ( (f , g) , Just cr)
(Guard p p':_) | dist ypos cpos < 900 && canSeeFireVisionAny cid (_yourID w) w
-> ( ( f , g')
@@ -1377,7 +1377,7 @@ closeToRangeAI inRange outRange w (f,g) cr =
-> ( (f , g)
, Just $ strafeCloseSlow ypos cr
) -- no longer chase if see you when reloading
-- $ replaceAction [] w
-- $ replaceAction [] w
| otherwise -> ( (f , g) , Just cr)
(Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr)
| otherwise
@@ -1483,7 +1483,7 @@ suppressShooterAI w (f,g) cr =
-> ( (f , g)
, Just $ turnCloseSlow ypos cr
) -- no longer chase if see you when reloading
-- $ replaceAction [] w
-- $ replaceAction [] w
| otherwise -> ( (f , g) , Just cr)
(Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr)
| otherwise
@@ -1587,7 +1587,7 @@ basicShooterAI w (f,g) cr =
-> ( (f , g)
, Just $ turnCloseSlow ypos cr
) -- no longer chase if see you when reloading
-- $ replaceAction [] w
-- -$ replaceAction [] w
| otherwise -> ( (f , g) , Just cr)
(Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr)
| otherwise
@@ -1689,7 +1689,7 @@ sniperAI w (f,g) cr =
-> ( (f , g)
, Just $ turnCloseSlow ypos cr
) -- no longer chase if see you when reloading
-- $ replaceAction [] w
-- $ replaceAction [] w
| otherwise -> ( (f , g) , Just cr)
(Search i:gls) | i == 0 -> ( (f , g) , replaceAction [] cr)
| otherwise
src/Dodge/Base.hs
+5 -5
View File
@@ -180,7 +180,7 @@ wallOnLine p1 p2 ws
wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> [Wall]
wallsOnCirc p r wls = IM.elems $ IM.filter f wls
where f wl = circOnLine (_wlLine wl !! 0) (_wlLine wl !! 1) p r
where f wl = circOnSeg (_wlLine wl !! 0) (_wlLine wl !! 1) p r
wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
wallsNearPoint p w = IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
@@ -653,11 +653,11 @@ collidePointCrsWithoutPoint cid p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd
f (cID,(p,_)) = (p,cID)
circOnSomeWall :: Point2 -> Float -> World -> Bool
circOnSomeWall p rad w = any (\(x:y:_) -> circOnLine x y p rad)
circOnSomeWall p rad w = any (\(x:y:_) -> circOnSeg x y p rad)
$ fmap _wlLine $ IM.elems $ wallsNearPoint p w
crsNearLine :: Float -> [Point2] -> World -> Bool
crsNearLine d (p1:p2:_) w = any (\c -> circOnLine p1 p2 (_crPos c) (d + _crRad c))
crsNearLine d (p1:p2:_) w = any (\c -> circOnSeg p1 p2 (_crPos c) (d + _crRad c))
$ IM.filter (\cr -> _crMass cr > 4) $ _creatures w
crsNearPoint :: Float -> Point2 -> World -> Bool
@@ -665,12 +665,12 @@ crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures
crsOnLine :: Point2 -> Point2 -> World -> [Creature]
crsOnLine p1 p2 w = IM.elems
$ IM.filter (\cr -> circOnLine p1 p2 (_crPos cr) (_crRad cr))
$ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
$ _creatures w
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature]
crsOnThickLine thickness p1 p2 w = IM.elems
$ IM.filter (\cr -> circOnLine p1 p2 (_crPos cr) (_crRad cr + thickness))
$ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
$ _creatures w
nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
src/Dodge/Creature.hs
+1 -1
View File
@@ -298,7 +298,7 @@ basicCrPict col cr = pictures [ onLayer CrLayer naked , drawEquipment cr]
where naked | pdam > 200 = color red $ circleSolid $ _crRad cr
| pdam > 100 = color white $ circleSolid $ _crRad cr
| mod pdam 2 == 1 = color white $ circleSolid $ _crRad cr
-- | crDam > _crHP cr && odd (crDam - _crHP cr)
-- | crDam > _crHP cr && odd (crDam - _crHP cr)
-- = [color white $ circleSolid $ _crRad cr]
| otherwise = pictures [color col $ circleSolid $ _crRad cr, circLine $ _crRad cr]
pdam = _crPastDamage $ _crState cr
src/Dodge/Creature/Property.hs
+2 -2
View File
@@ -14,7 +14,7 @@ crIsArmouredFrom p cr
-- even though angleVV can generate NaN, the comparison seems to deal with it
crOnSeg :: Point2 -> Point2 -> Creature -> Bool
crOnSeg p1 p2 cr = circOnLine p1 p2 (_crPos cr) (_crRad cr)
crOnSeg p1 p2 cr = circOnSeg p1 p2 (_crPos cr) (_crRad cr)
crNearSeg :: Float -> Point2 -> Point2 -> Creature -> Bool
crNearSeg d p1 p2 cr = circOnLine p1 p2 (_crPos cr) (_crRad cr + d)
crNearSeg d p1 p2 cr = circOnSeg p1 p2 (_crPos cr) (_crRad cr + d)
src/Dodge/Graph.hs
+21
View File
@@ -0,0 +1,21 @@
module Dodge.Graph
where
import Data.Function (on)
import Data.List
import Data.Graph
pairsToIncidence :: (Eq a,Ord a) => [(a,a)] -> [(a,[a])]
pairsToIncidence = map ((\(xs,ys) -> (head xs,ys)) . unzip)
. groupBy ( (==) `on` fst)
. sort
incidenceToFunction :: Eq a => [(a,[a])] -> a -> [a]
incidenceToFunction xs a = case lookup a xs of Just ys -> ys
Nothing -> []
mkNode :: (a,[a]) -> (a,a,[a])
mkNode (x,xs) = (x,x,xs)
pairsToSCC :: (Eq a, Ord a) => [(a,a)] -> [SCC a]
pairsToSCC = stronglyConnComp . map mkNode . pairsToIncidence
src/Dodge/Initialisation.hs
+4 -1
View File
@@ -20,7 +20,10 @@ initializeWorld :: World -> World
initializeWorld w = w
firstWorld :: IO World
firstWorld = return $ generateFromTree lev1 $ initialWorld
firstWorld = do
i <- randomRIO (0,5000)
putStrLn $ "Random seed for level generation: " ++ show ( i :: Int)
return $ generateFromTree lev1 $ initialWorld {_randGen = mkStdGen i}
initialWorld :: World
initialWorld = defaultWorld
src/Dodge/Item/Weapon.hs
+4 -4
View File
@@ -929,7 +929,7 @@ reflect a b = a + 2*(a-b)
moveGrenade :: Int -> Float -> Int -> World -> World
moveGrenade 0 dir pID w = over projectiles (IM.delete pID)
$ explosion (_pjPos (_projectiles w IM.! pID))
-- $ set (pointToItem (_itemPositions w IM.! wpID) . itEquipPict)
-- set (pointToItem (_itemPositions w IM.! wpID) . itEquipPict)
-- (drawWeapon $ grenadePic 50)
w
where
@@ -1493,7 +1493,7 @@ explodeRemoteBomb itid pjid n w
$ resetPict
-- $ resetScope
$ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w
-- $ makeShrapnelBombAt (_pjPos (_projectiles w IM.! pjid)) w
-- - $ makeShrapnelBombAt (_pjPos (_projectiles w IM.! pjid)) w
where
resetName = set (creatures . ix n . crInv . ix j . itName) "REMOTEBOMB"
resetPict = set (creatures . ix n . crInv . ix j . itEquipPict )
@@ -1656,7 +1656,7 @@ updateTractor colID time i w
$ over floorItems (IM.map tractFlIt)
w
| otherwise = over projectiles (IM.delete i) w
where tractCr cr | circOnLine p1 p2 cP 10
where tractCr cr | circOnSeg p1 p2 cP 10
= over crPos (\p ->
p -.- m *.* ((0.3/ x) *.* q +.+ (f y *.* p4))
) cr
@@ -1666,7 +1666,7 @@ updateTractor colID time i w
cP = _crPos cr
m | dist cP p1 < 350 = 1
| otherwise = (400 - dist cP p1) / 50
tractFlIt it | circOnLine p1 p2 iP 10
tractFlIt it | circOnSeg p1 p2 iP 10
= over flItPos (\p -> p -.- m *.*
( (0.3/ x) *.* q +.+ (f y *.* p4))
) it
src/Dodge/Layout.hs
+4 -4
View File
@@ -8,7 +8,7 @@ import Dodge.Data
import Dodge.LevelGen
import Dodge.Base
import Dodge.RandomHelp
import Dodge.Path
import Dodge.Graph
import Dodge.Layout.Tree
import Dodge.Room.Data
import Dodge.Default
@@ -64,10 +64,10 @@ makePath = concat . map _rmPath . flatten
-- consider nubbing walls after dividing them
wallsFromTree :: Tree Room -> IM.IntMap Wall
wallsFromTree t =
createInnerWalls
. divideWalls
-- createInnerWalls
divideWalls
. assignKeys
. foldr cutWalls [] -- $ map (map (g . roundPoint2))
. foldr cutWalls [] -- map (map (g . roundPoint2))
-- . map (map roundPoint2)
$ (concatMap _rmPolys $ flatten t)
where
src/Dodge/Layout/LockAndKey.hs
+14
View File
@@ -0,0 +1,14 @@
module Dodge.Layout.LockAndKey
where
data Key = Key Int
-- data Area
-- = Area
-- { _arID :: Int
-- , _arLinks :: [Int]
-- , _arMonsters :: [Creature]
-- , _arItems :: [Item]
-- }
--generateGraph
src/Dodge/LevelGen.hs
+1 -1
View File
@@ -3,7 +3,7 @@
module Dodge.LevelGen
( module Dodge.LevelGen
, cutWalls
, createInnerWalls
-- , createInnerWalls
, pairsToGraph
, makeButton
, makeSwitch
src/Dodge/LevelGen/InnerWalls.hs
+46
View File
@@ -0,0 +1,46 @@
module Dodge.LevelGen.InnerWalls
where
import Dodge.Data
import Dodge.Base
import Geometry
import Control.Lens
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
src/Dodge/LevelGen/StaticWalls.hs
+102 -87
View File
@@ -1,3 +1,7 @@
{-|
Module : Dodge.LevelGen.StaticWalls
Description : Concerns carving out of static walls to create the general room plan of the level.
-}
module Dodge.LevelGen.StaticWalls
where
import Dodge.Data
@@ -10,6 +14,7 @@ import Control.Lens
import Data.Function (on)
import Data.Graph
import Data.List
import Data.Maybe
import qualified Data.IntMap as IM
@@ -18,9 +23,22 @@ import qualified Data.Set as S
type WallP = (Point2,Point2)
-- the following checks one of the corners of cut walls at each step
-- | Cut out a polygon from a set of walls, and check for errors in the
-- created walls.
-- If created walls are not consistent, expand poly and retry.
cutWalls :: [Point2] -> [WallP] -> [WallP]
cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
[] -> newWalls
_ -> cutWalls (expandPolyBy 0.01 ps) wls
where
newWalls = cutWalls' ps wls
errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
-- | Cut out a polygon from a set of walls, and check for errors in the
-- created walls.
-- Give error if created walls are not consistent.
cutWalls'' :: [Point2] -> [WallP] -> [WallP]
cutWalls'' ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
[] -> newWalls
errs -> error $ "during level generation function cutWalls: when cutting poly:\n" ++ show ps
++ "\nRight corner errors:\n"
@@ -35,17 +53,42 @@ cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
newWalls = cutWalls' ps wls
errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
-- | Given a specific wall and list of walls, checks that the number of walls leaving the
-- second point is the same as the number of walls entering the second point of
-- the specific wall.
-- On success returns Nothing, on failure returns Just the specific wall and the
-- list of walls leaving the second point.
checkWallRight :: WallP -> [WallP] -> Maybe (WallP,[WallP])
checkWallRight (x,y) wls = case filter (\(a,b) -> a == y ) wls of
[w] -> Nothing
wls -> Just ((x,y), wls)
checkWallRight (x,y) wls
| length ins == length outs = Nothing
| otherwise = Just ((x,y), outs)
where
ins = filter (\(a,b) -> b == y) wls
outs = filter (\(a,b) -> a == y) wls
-- | Given a specific wall and list of walls, checks that the number of walls leaving the
-- first point is the same as the number of walls entering the first point of
-- the specific wall.
-- On success returns Nothing, on failure returns Just the specific wall and the
-- list of walls leaving the first point.
checkWallLeft :: WallP -> [WallP] -> Maybe (WallP,[WallP])
checkWallLeft (x,y) wls = case filter (\(a,b) -> b == x ) wls of
[w] -> Nothing
wls -> Just ((x,y),wls)
checkWallLeft (x,y) wls
| length ins == length outs = Nothing
| otherwise = Just ((x,y), outs)
where
ins = filter (\(a,b) -> a == x) wls
outs = filter (\(a,b) -> b == x) wls
-- given a polygon of points and collection of walls, cuts out the polygon
-- ie returns a new set of walls with a hole determined by anticlockwise ordering of the points
-- | Given a polygon of points and collection of walls, cuts out the polygon.
-- Ie returns a new set of walls with a hole determined by anticlockwise ordering of the points.
-- The overall procedure is:
-- 1. split walls that intersect with the polygon into two
-- (possibly three if the wall extends across the polygon),
-- 2. remove any created walls that are inside the polygon,
-- 3. create the required new walls along the polygon boundary.
-- 4. fuse wall endpoints that end up close to each or to polygon intersection points
-- 5. remove any walls that ended up zero length after fusing
-- 6. remove any duplicate walls
-- Unclear behaviour if a line in the polygon is colinear with a wall.
cutWalls' :: [Point2] -> [WallP] -> [WallP]
cutWalls' qs walls =
nub
@@ -61,18 +104,19 @@ cutWalls' qs walls =
(zs,cwals) = cutWallsWithPoints ps walls
ps = orderPolygon qs
rs = orderPolygon $ nub $ zs ++ qs
-- the overall procedure is:
-- split walls that intersect with the polygon into two
-- (possibly three if the wall extends across the polygon)
-- remove any created walls that are inside the polygon
-- create the required new walls along the polygon boundary
-- fuse wall endpoints that end up close to each or to polygon intersection points
-- remove any walls that ended up zero length after fusing
-- remove any duplicate walls
-- given a polygon expressed as a list of points and a collection of walls,
-- returns: fst: points of the polygon's intersection with walls
-- snd: the collection of walls after cutting by the polygon
-- | Given a value and a poly, pushes the poly points out from the center by the
-- value amount.
expandPolyBy :: Float -> [Point2] -> [Point2]
expandPolyBy x ps = map f ps
where
cp = (1/(fromIntegral (length ps))) *.* (foldr (+.+) (0,0) ps)
f p = p +.+ x *.* (p -.- cp)
-- | Given a polygon expressed as a list of points and a collection of walls,
-- returns:
-- fst: points of the polygon's intersection with walls
-- snd: the collection of walls after cutting by the polygon.
cutWallsWithPoints :: [Point2] -> [WallP] -> ([Point2], [WallP] )
cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
where
@@ -81,12 +125,12 @@ cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
, concatMap (cutWall p1 p2) ws'
)
-- lists the points of intersection between a segment and collection of walls
-- | List the points of intersection between a segment and collection of walls.
cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2]
--cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y)
cutWallsPoints p1 p2 ws = mapMaybe (uncurry $ myIntersectSegSeg p1 p2) ws
-- given a segment and a wall, split the wall into two if it crosses the segment
-- | Given a segment and a wall, split the wall into two if it crosses the segment.
cutWall :: Point2 -> Point2 -> WallP -> [WallP]
cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of
Nothing -> [(x,y)]
@@ -95,60 +139,63 @@ cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of
addPolyWalls :: [Point2] -> [WallP] -> [WallP]
addPolyWalls (q:qs) walls = foldr addPolyWall walls (zip (q:qs) (qs++[q]))
-- adds a wall if there is not already a wall on the clockwise normal to this wall
-- such that this existing wall faces towards the new wall
-- | Add a new wall to a list of walls only if either
-- 1. no wall already exists on the normal line from the new wall
-- 2. any of the first existing walls hit on the normal line from the new wall
-- face away from the new wall.
-- The normal line is the line from the center point of the new wall outwards
-- along the clockwise normal of the new wall (currently 10000 units along)
addPolyWall :: WallP -> [WallP] -> [WallP]
addPolyWall (p1,p2) walls =
case maybeW of Just (x,y) -> if isLHS x y p3
then walls
else (p1,p2) : walls
Nothing -> ((p1,p2) : walls)
addPolyWall (p1,p2) walls =
case maybeWs of
Just ws -> if all (\(x,y) -> isLHS x y p3) ws
then walls
else (p1,p2) : walls
Nothing -> ((p1,p2) : walls)
where
p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
maybeW = listToMaybe
. fst
. unzip
. sortBy (compare `on` (dist p3 . snd))
maybeWs = -- listToMaybe .
fmap fst
. fmap unzip
. listToMaybe
$ groupBy ((==) `on` (dist p3 . snd))
wlsP
wlsP :: [(WallP, Point2)]
wlsP = sortBy (compare `on` (dist p3 . snd))
. catMaybes
$ zipWith f walls maybes
f a (Just b) = Just (a,b)
f _ Nothing = Nothing
maybes = map (uncurry $ myIntersectSegSeg p3 p4) walls
-- intersects two segments, each extended by one unit in both directions
intersectExtendedSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2'
where
p1' = p1 +.+ normalizeV (p1 -.- p2)
p2' = p2 +.+ normalizeV (p2 -.- p1)
a1' = a1 +.+ normalizeV (a1 -.- a2)
a2' = a2 +.+ normalizeV (a2 -.- a1)
-- given a list of points and a point, returns a point in the list if any is close
-- enough to the point
-- | Given a list of points and a point, returns a point in the list if any is close
-- to the point.
findClosePoint :: [Point2] -> Point2 -> Maybe Point2
findClosePoint ps p = find (\q -> dist p q < 5) ps
-- | Given a list of points and a point, returns the point if none in the list
-- is close to the point.
pointIfNotClose :: [Point2] -> Point2 -> Maybe Point2
pointIfNotClose ps p = case findClosePoint ps p of
Nothing -> Just p
_ -> Nothing
-- fuses a point with one in a list if any are close enough
-- | Fuses a point with one in a list if any are close enough.
fusePoint :: [Point2] -> Point2 -> Point2
fusePoint ps p = fromMaybe p $ findClosePoint ps p
-- given a list of points and wall, moves the wall to be on the points if it is
-- close to any of the points
-- if either wall point is not moved, this point gets added to the list
-- | Given a list of points and wall, moves the wall to be on the points if it is
-- close to any of the points.
-- If either wall point is not moved, this point gets added to the list.
fuseWall :: ([Point2], WallP) -> ([Point2], WallP)
fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') )
where
x' = fusePoint ps x
y' = fusePoint (x':ps) y
-- given list of points and collection of walls, fuses the wall ends if
-- they are close to the list of points or each other
-- | Given list of points and collection of walls, fuses the wall ends if
-- they are close to the list of points or each other.
fuseWallsWith :: [Point2] -> [WallP] -> [WallP]
fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws
where
@@ -156,47 +203,15 @@ fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws
let (qs, w') = fuseWall (ps, w)
in (qs, w' : ws)
-- | Test if fst p == snd p.
wallIsZeroLength (x,y) = x == y
-- | Given a polygon and list of walls, removes walls inside the polygon.
removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
removeWallsInPolygon ps walls = filter (not . cond) walls
where
cond wall = pointInsidePolygon (fst wall) ps
&& pointInsidePolygon (snd wall) ps
cond wall =
pointInOrOnPolygon (0.5 *.* (fst wall +.+ snd wall)) ps
-- pointInOrOnPolygon (fst wall) ps
-- && pointInOrOnPolygon (snd wall) ps
------------------------------------------------------------------------------------
-- 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
src/Dodge/Path.hs
+1 -9
View File
@@ -1,6 +1,7 @@
module Dodge.Path where
import Dodge.Data
import Dodge.Base
import Dodge.Graph
import Geometry
@@ -160,12 +161,3 @@ maybeToEither :: a -> Maybe b -> Either a b
maybeToEither _ (Just x) = Right x
maybeToEither y Nothing = Left y
pairsToIncidence :: (Eq a,Ord a) => [(a,a)] -> [(a,[a])]
pairsToIncidence = map ((\(xs,ys) -> (head xs,ys)) . unzip)
. groupBy ( (==) `on` fst)
. sort
incidenceToFunction :: Eq a => [(a,[a])] -> a -> [a]
incidenceToFunction xs a = case lookup a xs of Just ys -> ys
Nothing -> []
src/Dodge/Render/Picture.hs
+1 -1
View File
@@ -176,7 +176,7 @@ drawFFShadow w ff
fCol = color (_ffColor ff)
col = _ffColor ff
ypShift = yp -.- _cameraCenter w
youOnFF = circOnLine' x' y' ypShift (_crRad $ you w)
youOnFF = circOnSeg x' y' ypShift (_crRad $ you w)
pane j = color (withAlpha 0.1 col)
$ polygon
$ [ x
src/Dodge/WallCreatureCollisions.hs
+1 -1
View File
@@ -77,7 +77,7 @@ pushOutFromWall rad cp2 (wp1:wp2:_)
wp1' = (rad *.* norm) +.+ wp1
wp2' = (rad *.* norm) +.+ wp2
newP = errorClosestPointOnLine 5 wp1' wp2' cp2
isOnWall = circOnLine' wp1 wp2 cp2 rad
isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
isJust Nothing = False
isJust _ = True
src/Dodge/WorldEvent.hs
+1 -1
View File
@@ -111,7 +111,7 @@ createBarrelSpark time colid pos dir maycid w = over worldEvents
damCrsOnLine :: Int -> Point2 -> Point2 -> World -> World
damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine)
where damIfOnLine cr | circOnLine p1 p2 (_crPos cr) (_crRad cr)
where damIfOnLine cr | circOnSeg p1 p2 (_crPos cr) (_crRad cr)
= over crHP (\hp -> hp - dam) cr
| otherwise = cr
src/Dodge/WorldEvent/Flash.hs
+1 -1
View File
@@ -61,7 +61,7 @@ lowLightPic :: Float -> Float -> Color -> (Point2, Point2) -> World -> Picture
lowLightPic len wdth col (a,b) w
= case thingsHit a b w of
((p, E3x2 wall):_)
-> setCol . lineOfThickness wdth $ [alongLineBy len p wa, alongLineBy len p wb]
-> setCol . lineOfThickness wdth $ [alongSegBy len p wa, alongSegBy len p wb]
where x = len *.* (normalizeV $ wa -.- wb)
(wa:wb:_) = _wlLine wall
((p, E3x1 cr):_)
src/Dodge/WorldEvent/ThingsHit.hs
+2 -2
View File
@@ -15,7 +15,7 @@ thingsHit sp ep w
| sp == ep = []
| otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
where
hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
$ _creatures w
-- $ creaturesAlongLine sp ep w
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
@@ -53,7 +53,7 @@ thingsHitLongLine sp ep w
| otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
where
crs = zip crPs (map E3x1 hitCrs)
hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
$ _creatures w
-- $ creaturesAlongLine sp ep w
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs