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
bench/Bench.hs
+22 -1
View File
@@ -1,4 +1,25 @@
import Criterion.Main
import Dodge.RandomHelp
import Geometry
import System.Random
import Control.Monad.State
import Data.List (zip4)
main :: IO ()
main = putStrLn "h"
main = do
[ps1, ps2, ps3, ps4] <- mapM randomPoints [500,500,500,500]
fs <- sequence $ replicate 500 (randomRIO (1,20))
defaultMain
[ bgroup "circLine tests"
[ bench "circLine" $ nf (map $ uncurry4 circOnLine) (zip4 ps1 ps2 ps3 fs)
, bench "circLine'" $ nf (map $ uncurry4 circOnLine') (zip4 ps1 ps2 ps3 fs)
]
]
uncurry4 f (a,b,c,d) = f a b c d
randomPoints :: Int -> IO [Point2]
randomPoints i = getStdGen >>= return . evalState (sequence $ replicate i $ randInCirc 500)
package.yaml
+2
View File
@@ -46,6 +46,7 @@ dependencies:
- linear
- aeson
- directory
- QuickCheck
library:
source-dirs: src
@@ -84,6 +85,7 @@ benchmarks:
loop-benchmarks:
dependencies:
- criterion
- loop
ghc-options:
- -threaded
- -O2
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
src/Geometry.hs
+156 -106
View File
@@ -1,4 +1,13 @@
{-# LANGUAGE BangPatterns #-}
{-|
Module : Geometry
Description : Geometry helpers
This module provides geometry functions that manipulate pairs of floats.
Conventions:
Seg refers to a segment, typically defined by two points, and will typically not extend beyond either of these points.
Line refers to a line defined by two points, and extends beyond the two points.
-}
module Geometry
( module Geometry
, module Geometry.Data
@@ -17,54 +26,61 @@ import Data.List
import Data.Maybe
import Control.Applicative
-- TODO add bang patterns
alongLineBy :: Float -> Point2 -> Point2 -> Point2
alongLineBy !x !a !b = a +.+ y *.* normalizeV (b -.- a)
-- | Return a point a distance away from a first point towards a second point.
-- Does not go past the second point.
alongSegBy :: Float -> Point2 -> Point2 -> Point2
alongSegBy !x !a !b = a +.+ y *.* normalizeV (b -.- a)
where
y = min x $ dist a b
closestPointOnLine :: Point2 -> Point2 -> Point2 -> Point2
-- | Given a line and a point return the point on the line closest to the
-- point.
closestPointOnLine
:: Point2 -- ^ First line point.
-> Point2 -- ^ Second line point.
-> Point2 -- ^ Point not on line.
-> Point2
{-# INLINE closestPointOnLine #-}
closestPointOnLine !a !b !p = a +.+ u *.* (b -.- a)
closestPointOnLine !a !b !p = a +.+ u *.* (b -.- a)
where u = closestPointOnLineParam a b p
closestPointOnLineParam :: Point2 -> Point2 -> Point2 -> Float
-- | Given a line and a point return a value corresponding to how far along the
-- line the point is.
closestPointOnLineParam
:: Point2 -- ^ First line point.
-> Point2 -- ^ Second line point.
-> Point2 -- ^ Point not on line.
-> Float
{-# INLINE closestPointOnLineParam #-}
closestPointOnLineParam !a !b !p
= (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a)
-- the following helper draws a rectangle based on maximal N E S W values
-- | Draw a rectangle based on maximal N E S W values.
rectNESW :: Float -> Float -> Float -> Float -> [Point2]
rectNESW !a !b !c !d = [(b,a),(b,c),(d,c),(d,a) ]
-- | Draw a rectangle based on maximal N S E W values.
rectNSEW :: Float -> Float -> Float -> Float -> [Point2]
rectNSEW !n !s !e !w = rectNESW n e s w
-- | Draw a rectangle based on maximal N S W E values.
rectNSWE :: Float -> Float -> Float -> Float -> [Point2]
rectNSWE !n !s !w !e = [ (w,n), (w,s), (e,s), (e,n)]
-- -- the following filters points in a polygon: supposes the points in the
-- polygon are listed in anticlockwise order
-- | Test whether a point is in a polygon or on the polygon border.
-- Supposes the points in the
-- polygon are listed in anticlockwise order.
pointInOrOnPolygon :: Point2 -> [Point2] -> Bool
pointInOrOnPolygon !p (x:xs) = all (\l -> not (uncurry isRHS l p)) $ zip (x:xs) (xs ++ [x])
-- | Test whether a point is strictly inside a polygon.
-- Supposes the points in the polygon are listed in anticlockwise order.
pointInPolygon :: Point2 -> [Point2] -> Bool
pointInPolygon !p [] = False
pointInPolygon !p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x])
pointInsidePolygon :: Point2 -> [Point2] -> Bool
pointInsidePolygon !p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs
|| any (\l -> uncurry isOnLine l p) pairs
where
pairs = zip (x:xs) (xs ++ [x])
s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs))) -.- p
-- | Debug version of 'pointInPolygon'.
errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool
errorPointInPolygon !i !p xs
| length xs == 1 = error "one point polygon"
@@ -72,43 +88,53 @@ errorPointInPolygon !i !p xs
| nub xs == xs = pointInPolygon p xs
| otherwise = error $ "errorPointInPolygon "++ show i
-- | Debug version of 'normalizeV'.
errorNormalizeV :: Int -> Point2 -> Point2
errorNormalizeV !i !(0,0) = error $ "problem with function: errorNormalizeV "++show i
errorNormalizeV !i !p = normalizeV p
-- | Debug version of 'angleVV'.
errorAngleVV :: Int -> Point2 -> Point2 -> Float
errorAngleVV !i !(0,0) _ = error $ "problem with function: errorAngleVV "++show i
errorAngleVV !i _ !(0,0) = error $ "problem with function: errorAngleVV "++show i
errorAngleVV !i !p !p' = angleVV p p'
-- | Debug version of 'isLHS'.
errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool
errorIsLHS !i !x !y
| x == y = error $ "problem with function: errorIsLHS " ++show i
| otherwise = isLHS x y
-- | Debug version of 'closestPointOnLine'
errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2
errorClosestPointOnLine !i !x !y
| x == y = error $ "problem with function: errorClosestPointOnLine " ++show i
| otherwise = closestPointOnLine x y
-- | Debug version of 'closestPointOnLineParam'
errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float
errorClosestPointOnLineParam !i !x! y! z
| x == y = dist x z
| otherwise = closestPointOnLineParam x y z
-- | Normalize a vector to be unit length.
-- For (0,0) return (0,0).
safeNormalizeV :: Point2 -> Point2
safeNormalizeV !(0,0) = (0,0)
safeNormalizeV !p = normalizeV p
-- tests whether a point is on the LHS of a line
isLHS :: Point2 -> Point2 -> Point2 -> Bool
-- | Test whether a point is on the LHS of a line.
-- Returns False if the line is of zero length.
isLHS
:: Point2 -- ^ First line point.
-> Point2 -- ^ Second line point.
-> Point2 -- ^ Point not on line.
-> Bool
{-# INLINE isLHS #-}
isLHS' :: (Float, Float) -> (Float, Float) -> Point2 -> Bool
isLHS' !l1 !l2 !p
| l1 == l2 = False
| otherwise = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p < 0
isLHS !(x,y) !(x',y') !(x'',y'')
isLHS
!(x,y)
!(x',y')
!(x'',y'')
| (x,y) == (x',y') = False
| otherwise = a1 * b2 - a2 * b1 > 0
where
@@ -117,9 +143,18 @@ isLHS !(x,y) !(x',y') !(x'',y'')
b1 = x'' - x
b2 = y'' - y
isRHS :: Point2 -> Point2 -> Point2 -> Bool
-- | Test whether a point is on the LHS of a line.
-- Returns False if the line is of zero length.
isRHS
:: Point2 -- ^ First line point.
-> Point2 -- ^ Second line point.
-> Point2 -- ^ Point not on line.
-> Bool
{-# INLINE isRHS #-}
isRHS !(x,y) !(x',y') !(x'',y'')
isRHS
!(x,y)
!(x',y')
!(x'',y'')
| (x,y) == (x',y') = False
| otherwise = a1 * b2 - a2 * b1 < 0
where
@@ -128,54 +163,69 @@ isRHS !(x,y) !(x',y') !(x'',y'')
b1 = x'' - x
b2 = y'' - y
-- reorders points to be anticlockwise around their center
-- | Reorder points to be anticlockwise around their center.
orderPolygon :: [Point2] -> [Point2]
orderPolygon [] = []
orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps
where
cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps
-- | Return distance between two points.
dist :: Point2 -> Point2 -> Float
{-# INLINE dist #-}
dist !p1 !p2 = magV (p2 -.- p1)
-- | Return midpoint between two points.
pHalf :: Point2 -> Point2 -> Point2
pHalf !a !b = 0.5 *.* (a +.+ b)
circOnLine' :: Point2 -> Point2 -> Point2 -> Float -> Bool
circOnLine' !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
-- | Test whether a circle is on a segment by intersecting a new normal segment through the
-- center of the circle with the segment itself.
-- Returns False if the circle center is beyond the enpoints of the
-- segment.
circOnSegNoEndpoints :: Point2 -> Point2 -> Point2 -> Float -> Bool
{-# INLINE circOnSegNoEndpoints #-}
circOnSegNoEndpoints !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
where
y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
isJustTrue (Just True) = True
isJustTrue _ = False
-- this should probably be circOnSeg
circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool
{-# INLINE circOnLine #-}
circOnLine !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad
-- | Test whether a circle is on a segment by intersecting a normal and testing
-- the distance to the endpoints of the segment.
circOnSeg :: Point2 -> Point2 -> Point2 -> Float -> Bool
{-# INLINE circOnSeg #-}
circOnSeg !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad
|| isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
where
y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
isJustTrue (Just True) = True
isJustTrue _ = False
-- | Find the difference between two Nums.
difference :: (Ord a, Num a) => a -> a -> a
difference x y
| x > y = x - y
| otherwise = y - x
-- | Given vector line direction and a vector movement,
-- reflects the movement accoring to the line.
reflectIn :: Point2 -> Point2 -> Point2
reflectIn line vec =
let angle = 2 * angleBetween line vec
in rotateV angle vec
-- | Find angle between two points.
-- Not normalised, ranges from -2*pi to 2*pi.
angleBetween :: Point2 -> Point2 -> Float
angleBetween v1 v2 = argV v1 - argV v2
-- | Return a list containing two copies of a pair.
doublePair :: (a,a) -> [(a,a)]
doublePair (x,y) = [(x,y),(y,x)]
-- | Test whether two polygons intersect by testing the intersection of each
-- consecutive pair of points.
polysIntersect :: [Point2] -> [Point2] -> Bool
polysIntersect (p:ps) (q:qs)
= any isJust $ (\(a,b) (c,d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2
@@ -186,25 +236,33 @@ polysIntersect (p:ps) (q:qs)
polysIntersect [] _ = False
polysIntersect _ [] = False
-- | Test whether any polygons from a first list intersect with any polygons from
-- a second list.
anyPolyssIntersect :: [[Point2]] -> [[Point2]] -> Bool
anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y
-- | Return n equidistant points on a circle with a radius of 600.
nRays :: Int -> [Point2]
nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) (600,0)
-- | Return n equidistant points on a circle with a radius of x.
nRaysRad :: Int -> Float -> [Point2]
nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (x,0)
-- angles go from 0 to 2pi, need to work out what is left of another
-- | Test whether an angle is to the left of another angle, according to the
-- smallest change in rotation between them.
isLeftOfA :: Float -> Float -> Bool
isLeftOfA angle1 angle2 =
(angle1 - angle2 < pi && angle1 > angle2)
|| (angle2 - angle1 > pi && angle2 > angle1)
-- | Test whether a vector is to the left of another, according to the smallest
-- change of rotation between them.
isLeftOf :: Point2 -> Point2 -> Bool
isLeftOf x y = isLeftOfA (argV x) (argV y)
-- diffAngles has an issue...
-- | Find the difference between two angles.
-- Possibly not correct...
diffAngles :: Float -> Float -> Float
diffAngles x y
| diff > pi = diffAngles (x - 2*pi) y
@@ -217,10 +275,10 @@ diffAngles x y
differenceAngles = diffAngles
angleDifference = diffAngles
-- given a triangle where we know the length of a first side,
-- | Given a triangle where we know the length of a first side,
-- the length of a second side, and the angle between the first side and the
-- third side, finds the length of the third side
-- not this doesn't necessarily find ALL solutions, asin is a map not a function
-- third side, finds the length of the third side.
-- Note this doesn't necessarily find ALL solutions, asin is a map not a function.
ssaTri :: Float -> Float -> Float -> Float
ssaTri ab bc a
| sin a == 0 = 0
@@ -230,12 +288,10 @@ ssaTri ab bc a
b = pi - (a + c)
in sin b * bc / sin a
-- fix points: we now fix the triangle in the coordinate system, and return a
-- third unknown point:
-- the point which lies between pa and pc' on a line from b of length bc
-- note that there are likely two such points, this seems to return the point
-- closer to pc'
-- | Given two points of a triangle and a third point, return
-- the point which lies between pa and pc' on a line from pb of length bc.
-- Note that there are likely two such points, this should return the point
-- closer to pc'.
ssaTriPoint :: Point2 -> Point2 -> Point2 -> Float -> Point2
ssaTriPoint pa pb pc' bc
= let ab = magV (pa -.- pb)
@@ -243,13 +299,15 @@ ssaTriPoint pa pb pc' bc
ac = ssaTri ab bc a
in pa +.+ (ac *.* errorNormalizeV 47 (pc' -.- pa))
-- the above SHOULD return a Maybe Point...
-- | Safe version of 'ssaTriPoint'.
ssaTriPoint' :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2
ssaTriPoint' pa pb pc' bc
| dist pb (closestPointOnSeg pa pc' pb) >= bc
= Nothing
| otherwise
= Just $ ssaTriPoint pa pb pc' bc
-- | A potential correction of 'ssaTriPoint'.
-- This should be tested and benchmarked.
ssaTriPointCorrect :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2
ssaTriPointCorrect pa pb pc' bc
| param <= 1 && param >= 0 = Just p
@@ -258,42 +316,42 @@ ssaTriPointCorrect pa pb pc' bc
p = ssaTriPoint pa pb pc' bc
param = closestPointOnLineParam pa pc' p
-- | Given a segment and external point, find the closest point on the segment.
closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2
closestPointOnSeg segP1 segP2 p
| errorClosestPointOnLineParam 3 segP1 segP2 p <= 0 = segP1
| errorClosestPointOnLineParam 4 segP1 segP2 p >= 1 = segP2
| otherwise = errorClosestPointOnLine 2 segP1 segP2 p
-- | Return Just a point if it is inside a circle, Nothing otherwise.
pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2
pointInCircle p r c
| p == c = Just p
| magV (p -.- c) < r = Just p
| otherwise = Nothing
--determines if a moving point intersects with a circle,
--if so, returns a point on circle that intersects with the line passing
--throught the circle : HOPEFULLY THE CORRECT OF THE TWO!
-- | Determines if a moving point intersects with a circle,
-- if so, returns a point on circle that intersects with the line passing
-- throught the circle : HOPEFULLY THE CORRECT OF THE TWO!
collidePointCirc :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2
collidePointCirc p1 p2 rad c = ssaTriPoint' p2 c p1 rad
-- changes the point to a measure of the distance
-- | As 'collidePointCirc', but changes the point to a measure of the distance.
collidePointCirc' :: Point2 -> Point2 -> Float -> Point2 -> Maybe Float
collidePointCirc' p1 p2 rad c = fmap (\x -> magV (x -.- p1))
(collidePointCirc p1 p2 rad c)
--returns both the point and the measure of the distance
-- | As 'collidePointCirc', but returns both the point and the measure of the distance.
collidePointCirc'' :: Point2 -> Point2 -> Float -> Point2 -> Maybe (Point2,Float)
collidePointCirc'' p1 p2 rad c = (,) <$> collidePointCirc p1 p2 rad c
<*> collidePointCirc' p1 p2 rad c
-- | As 'collidePointCirc', but uses the supposedly correct version of ssaTriPoint.
collidePointCircCorrect :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2
collidePointCircCorrect p1 p2 rad c = ssaTriPointCorrect p2 c p1 rad
-- finds the height of a triangle using herons formula
-- the base is the line between the first two points
-- | Finds the height of a triangle using herons formula.
-- The base is the line between the first two points.
heron :: Point2 -> Point2 -> Point2 -> Float
heron x y z
| x == y = 0
@@ -304,7 +362,8 @@ heron x y z
s = (a+b+c)/2
area = sqrt(s*(s-a)*(s-b)*(s-c))
in 2*area/a
-- multiplies reflection in normal by factor
-- | Multiplies reflection in normal by factor.
reflectInParam :: Float -> Point2 -> Point2 -> Point2
reflectInParam x line vec =
let angle = 2 * angleBetween line vec
@@ -312,16 +371,17 @@ reflectInParam x line vec =
p = x *.* errorClosestPointOnLine 3 (0,0) (vNormal line) rAng
in rAng -.- p
--reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2
--reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1)
reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2
reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1)
isOnLine :: Point2 -> Point2 -> Point2 -> Bool
isOnLine l1 l2 p =
errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0
&& errorClosestPointOnLineParam 11 l1 l2 p <= 1
&& errorClosestPointOnLineParam 12 l1 l2 p >= 0
--isOnSeg :: Point2 -> Point2 -> Point2 -> Bool
--isOnSeg l1 l2 p =
-- errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0
-- && errorClosestPointOnLineParam 11 l1 l2 p <= 1
-- && errorClosestPointOnLineParam 12 l1 l2 p >= 0
-- | Divide a segment into a list of points with a maximal distance between
-- them.
-- the take 5000 here is a hack, otherwise divideLine seems to sometimes
-- generate an infinite list, and I don't know why
divideLine :: Float -> Point2 -> Point2 -> [Point2]
@@ -335,6 +395,7 @@ divideLine x a b =
numPoints = max 1 $ ceiling $ d / x
ns = [0 .. numPoints]
-- | As 'divideLine', but must return an odd number of points.
divideLineOddNumPoints :: Float -> Point2 -> Point2 -> [Point2]
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
divideLineOddNumPoints x a b = take 5000
@@ -347,29 +408,8 @@ divideLineOddNumPoints x a b = take 5000
| otherwise = numPoints' + 1
ns = [0 .. numPoints]
-- pulled the following from the haskell wiki
-- it seems to produce an infinite loop sometimes
-- fuck that, don't trust random code on the internet
bresenham :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
{-# INLINE bresenham #-}
bresenham pa@(xa,ya) pb@(xb,yb) = map maySwitch . unfoldr go $ (x1,y1,0)
where
steep = abs (yb - ya) > abs (xb - xa)
maySwitch = if steep then (\(x,y) -> (y,x)) else id
[(x1,y1),(x2,y2)] = sort [maySwitch pa, maySwitch pb]
deltax = x2 - x1
deltay = abs (y2 - y1)
ystep = if y1 < y2 then 1 else -1
go (xTemp, yTemp, error)
| xTemp > x2 = Nothing
| otherwise = Just ((xTemp, yTemp), (xTemp + 1, newY, newError))
where
tempError = error + deltay
(newY, newError) =
if (2*tempError) >= deltax
then (yTemp+ystep,tempError-deltax)
else (yTemp,tempError)
-- | Given two pairs of Ints, returns a list of pairs of Ints that form
-- a digital line between them.
digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
digitalLine (x1,y1) (x2,y2)
| abs (x1-x2) > abs (y1-y2) = [ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) )
@@ -379,34 +419,44 @@ digitalLine (x1,y1) (x2,y2)
where
rdiv a b = round $ fromIntegral a / fromIntegral b
-- | Given two Ints, creates the list of Ints between these.
intervalList :: Int -> Int -> [Int]
intervalList x y
| y >= x = [x .. y]
| otherwise = reverse [y..x]
-- | Create points on the circumference of a circle with maximal distance
-- between them.
divideCircle :: Float -> Point2 -> Float -> [Point2]
divideCircle x cen rad = map (cen +.+) $ nPointsOnCirc n rad
divideCircle x cen rad = map (cen +.+) $ nRaysRad n rad
where
n = ceiling $ rad * 2 * pi / x
nPointsOnCirc :: Int -> Float -> [Point2]
nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0)
--nPointsOnCirc :: Int -> Float -> [Point2]
--nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0)
lineInPolygon :: Point2 -> Point2 -> [Point2] -> Bool
lineInPolygon a b ps =
pointInPolygon a ps
|| pointInPolygon b ps
|| any (isJust . uncurry (intersectSegSeg' a b)) pss
where
pss = zip ps (tail ps ++ [head ps])
--lineInPolygon :: Point2 -> Point2 -> [Point2] -> Bool
--lineInPolygon a b ps =
-- pointInPolygon a ps
-- || pointInPolygon b ps
-- || any (isJust . uncurry (intersectSegSeg' a b)) pss
-- where
-- pss = zip ps (tail ps ++ [head ps])
-- | Given a list of points, returns pairs of points linking the points into a
-- loop.
makeLoopPairs :: [Point2] -> [(Point2,Point2)]
makeLoopPairs [] = error "tried to make loop with empty list of points"
makeLoopPairs [x] = error "tried to make loop with singleton list of points"
makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x])
-- note the pair is ordered
-- doesn't work for obtuse angles
pointIsInCone :: Point2 -> (Point2,Point2) -> Point2 -> Bool
-- | Test whether a point is in a cone.
-- Note the pair is ordered.
-- Doesn't work for obtuse angles.
pointIsInCone
:: Point2 -- ^ Cone point.
-> (Point2,Point2) -- ^ Points delimiting the left and right boundaries of the cone.
-> Point2 -- ^ Point to test.
-> Bool
pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p
src/Loop.hs
+36 -32
View File
@@ -1,3 +1,9 @@
{-|
Module : Loop
Description : A minimal game loop
This module sets up an SDL window which may be updated using a simple game loop.
-}
module Loop
( setupLoop
) where
@@ -12,25 +18,17 @@ import Foreign.C
import Control.Lens ((.~),(&),(+~))
winConfig :: Int -> Int -> WindowConfig
winConfig x y = defaultWindow
{ windowGraphicsContext
= OpenGLContext (defaultOpenGL { glProfile = Core Normal 4 3
, glColorPrecision = V4 8 8 8 8
}
)
, windowInitialSize = V2 (fromIntegral x) (fromIntegral y)
, windowResizable =True
}
setupLoop
:: (Int,Int)
-> IO params
-> (params -> IO ())
-> IO world
-> (params -> world -> IO params)
-- | Create a game loop with an SDL window.
setupLoop
:: (Int,Int) -- ^ The window size.
-> IO params -- ^ Initial parameters.
-> (params -> IO ()) -- ^ Function for cleaning up parameters, applied when exiting loop.
-> IO world -- ^ Initial simulation state.
-> (params -> world -> IO params) -- ^ Parameter update, called once per frame. Allows for side effects such as rendering.
-> (world -> Event -> Maybe world)
-- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop.
-> (world -> Maybe world)
-- ^ Simulation update, once per frame. 'Nothing' exits the loop.
-> IO ()
setupLoop
(xSize,ySize)
@@ -53,13 +51,14 @@ setupLoop
paramCleanup
$ doLoop window startWorld sideEffects eventFn worldFn
-- | The internal loop.
doLoop
:: Window
-> world
-> (params -> world -> IO params)
-> (world -> Event -> Maybe world)
-> (world -> Maybe world)
-> params
:: Window -- ^ The SDL window.
-> world -- ^ Current simulation state.
-> (params -> world -> IO params) -- ^ Parameter update.
-> (world -> Event -> Maybe world) -- ^ SDL Event handling.
-> (world -> Maybe world) -- ^ Simulation update
-> params -- ^ Current parameters.
-> IO ()
doLoop
window
@@ -92,15 +91,8 @@ applyEventsIO
-> IO (Maybe world)
applyEventsIO fn w = foldM (applyEventIO fn) (Just w)
--eventCloseOrResize :: Event -> IO (Maybe Event)
--eventCloseOrResize e = case eventPayload e of
-- QuitEvent -> return Nothing
-- WindowClosedEvent _ -> return Nothing
-- WindowSizeChangedEvent (WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y})
-- -> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (Just e)
-- _ -> return $ Just e
--
-- | Handle quit events in a manner to exit the loop. Other events handled as
-- determined by the custom function, although resize events also change the viewport.
applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (Maybe world)
applyEventIO fn mw e = case eventPayload e of
QuitEvent -> return Nothing
@@ -109,3 +101,15 @@ applyEventIO fn mw e = case eventPayload e of
-> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e)
_ -> return $ mw >>= flip fn e
-- | Create an OpenGL SDL window configuration with a given x and y size.
winConfig :: Int -> Int -> WindowConfig
winConfig x y = defaultWindow
{ windowGraphicsContext
= OpenGLContext (defaultOpenGL { glProfile = Core Normal 4 3
, glColorPrecision = V4 8 8 8 8
}
)
, windowInitialSize = V2 (fromIntegral x) (fromIntegral y)
, windowResizable =True
}
test/Spec.hs
+52 -1
View File
@@ -1,2 +1,53 @@
import Test.QuickCheck
import Dodge.LevelGen.StaticWalls
import Geometry
main :: IO ()
main = putStrLn "Test suite not yet implemented"
main = do
putStrLn "Running tests:"
quickCheck prop_looping
nextPair :: Eq a => (a,a) -> [(a,a)] -> [(a,a)]
nextPair (_,y) = filter (\(x,_) -> x == y)
isLooping :: Eq a => [(a,a)] -> Bool
isLooping xs = all (( == 1) . length . flip nextPair xs) xs
isLooping' :: Eq a => [(a,a)] -> Bool
isLooping' xs = all (f xs) xs
where
f ys (x,y) = length ins == length outs && length rins == length routs
where
ins = filter (\(a,b) -> a == x) ys
outs = filter (\(a,b) -> b == x) ys
rins = filter (\(a,b) -> a == y) ys
routs = filter (\(a,b) -> b == y) ys
polygonStrictlyConvex :: [Point2] -> Bool
polygonStrictlyConvex ps = True
--prop_looping :: [Point2] -> [WallP] -> Bool
prop_looping = forAllShrink genTris shrinkTris $ \tris ->
(all (not . (\[a,b,c] -> isOnSeg a b c
|| isOnSeg a c b
|| isOnSeg b c a
) ) tris)
==> (isLooping' $ foldr cutWalls' [] tris)
shrinkTris [] = []
shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs)
genTri = zip <$> trip <*> trip
where
trip = vectorOf 3 $ fmap fromIntegral $ choose (0,3::Int)
genTris = listOf genTri
--extractLoops :: Eq a => [(a,a)] -> [[(a,a)]]
--extractLoops [] = []
--extractLoops (x:xs) =
--
--[[(0.0,1.0),(3.0,4.0),(5.0,5.0)],[(2.0,0.0),(2.0,4.0),(1.0,1.0)],[(5.0,5.0),(2.0,2.0),(1.0,3.0)]]