From 91e6e44f45135474584291e209db608e7454776c Mon Sep 17 00:00:00 2001 From: jgk Date: Thu, 1 Apr 2021 19:33:04 +0200 Subject: [PATCH 01/13] Create basic benchmarks for circOnLine --- bench/Bench.hs | 23 ++++++++++++++++++++++- package.yaml | 1 + 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/bench/Bench.hs b/bench/Bench.hs index 2a50cac83..7a0c03590 100644 --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -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) diff --git a/package.yaml b/package.yaml index 63eef0d8d..17b7c70f9 100644 --- a/package.yaml +++ b/package.yaml @@ -84,6 +84,7 @@ benchmarks: loop-benchmarks: dependencies: - criterion + - loop ghc-options: - -threaded - -O2 From 4327e94e0426ac8989b7cf02180d271552808d8b Mon Sep 17 00:00:00 2001 From: jgk Date: Fri, 2 Apr 2021 14:08:12 +0200 Subject: [PATCH 02/13] Move inner wall creation --- src/Dodge/Layout.hs | 4 +-- src/Dodge/LevelGen.hs | 2 +- src/Dodge/LevelGen/InnerWalls.hs | 46 +++++++++++++++++++++++++++++++ src/Dodge/LevelGen/StaticWalls.hs | 36 ------------------------ 4 files changed, 49 insertions(+), 39 deletions(-) create mode 100644 src/Dodge/LevelGen/InnerWalls.hs diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index a1461cd9e..e421ed7c5 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -64,8 +64,8 @@ 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)) -- . map (map roundPoint2) diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 05bdeecd6..11fa8a064 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -3,7 +3,7 @@ module Dodge.LevelGen ( module Dodge.LevelGen , cutWalls - , createInnerWalls +-- , createInnerWalls , pairsToGraph , makeButton , makeSwitch diff --git a/src/Dodge/LevelGen/InnerWalls.hs b/src/Dodge/LevelGen/InnerWalls.hs new file mode 100644 index 000000000..343cd0a1d --- /dev/null +++ b/src/Dodge/LevelGen/InnerWalls.hs @@ -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 diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 192104f16..562a0edac 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -164,39 +164,3 @@ removeWallsInPolygon ps walls = filter (not . cond) walls cond wall = pointInsidePolygon (fst wall) ps && pointInsidePolygon (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 From a735977bf8e3f1c13782d8ec558d3d5ed1f35db3 Mon Sep 17 00:00:00 2001 From: jgk Date: Fri, 2 Apr 2021 20:25:52 +0200 Subject: [PATCH 03/13] Temporary de-randomisation of random seed --- src/Dodge/Floor.hs | 68 +++++++++++++++---------------- src/Dodge/Initialisation.hs | 5 ++- src/Dodge/LevelGen/StaticWalls.hs | 29 ++++++++++--- 3 files changed, 61 insertions(+), 41 deletions(-) diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 60008b30a..e6f7b366c 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -36,41 +36,41 @@ lev1 = do ++ [return $ connectRoom corridor ,return $ connectRoom door ,glassSwitchBack >>= randomiseLinks] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [miniRoom3] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [roomCCrits] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++[roomMiniIntro] - ++ [longRoom >>= randomiseLinks] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] +-- ++ [miniRoom3] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] +-- ++ [roomCCrits] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] +-- ++[roomMiniIntro] +-- ++ [longRoom >>= randomiseLinks] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] ++ firstWeapon - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [randomiseLinks =<< pistolerRoom] - ++ [return $ connectRoom door] - ++ [randomiseLinks =<< shooterRoom] - ++ (replicate 3 $ randomiseLinks corridor) - ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] - ++ [return $ connectRoom corridor] - ++ (replicate 3 $ randomiseLinks corridor) - ++ [return $ connectRoom corridor] - ++[return $ connectRoom corridor,return $ connectRoom door] - ++ [shootingRange] - ++ (replicate 3 $ randomiseLinks corridor) - ++[roomMiniIntro] - ++ (replicate 3 $ randomiseLinks corridor) - ++ [return $ connectRoom corridor - ,return $ connectRoom door - ,slowDoorRoom] - ++ [return $ connectRoom corridor - ,spawnerRoom - ,return $ connectRoom corridor - ] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] +-- ++ [randomiseLinks =<< pistolerRoom] +-- ++ [return $ connectRoom door] +-- ++ [randomiseLinks =<< shooterRoom] +-- ++ (replicate 3 $ randomiseLinks corridor) +-- ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] +-- ++ [return $ connectRoom corridor] +-- ++ (replicate 3 $ randomiseLinks corridor) +-- ++ [return $ connectRoom corridor] +-- ++[return $ connectRoom corridor,return $ connectRoom door] +-- ++ [shootingRange] +-- ++ (replicate 3 $ randomiseLinks corridor) +-- ++[roomMiniIntro] +-- ++ (replicate 3 $ randomiseLinks corridor) +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door +-- ,slowDoorRoom] +-- ++ [return $ connectRoom corridor +-- ,spawnerRoom +-- ,return $ connectRoom corridor +-- ] ) $ randomiseLinks corridor diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index a5f064ab2..6fd6f79bc 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -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 diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 562a0edac..aa307d422 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -10,6 +10,7 @@ import Control.Lens import Data.Function (on) +import Data.Graph import Data.List import Data.Maybe import qualified Data.IntMap as IM @@ -48,10 +49,10 @@ checkWallLeft (x,y) wls = case filter (\(a,b) -> b == x ) wls of -- ie returns a new set of walls with a hole determined by anticlockwise ordering of the points cutWalls' :: [Point2] -> [WallP] -> [WallP] cutWalls' qs walls = - nub - . filter (not.wallIsZeroLength) - . fuseWallsWith zs - . addPolyWalls rs +-- nub +-- . filter (not.wallIsZeroLength) +-- . fuseWallsWith zs + addPolyWalls rs -- . removeWallsInPolygon ps -- . filter (not.wallIsZeroLength) -- . fuseWallsWith zs @@ -161,6 +162,22 @@ wallIsZeroLength (x,y) = x == y removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP] removeWallsInPolygon ps walls = filter (not . cond) walls where - cond wall = pointInsidePolygon (fst wall) ps - && pointInsidePolygon (snd wall) ps + cond wall = pointInsidePolygon (0.5 *.* (fst wall +.+ snd wall)) ps +-- pointInsidePolygon (fst wall) ps +-- && pointInsidePolygon (snd wall) ps + + +--pairElems :: Eq a => [(a,a)] -> [a] +--pairElems = concatMap flat2 +-- where +-- flat2 (x,y) = [x,y] +-- +--findLinkedPairs :: Eq a => (a,a) -> [(a,a)] -> [(a,a)] +--findLinkedPairs (x,y) = ( (x,y) : ) . filter f +-- where +-- f (a,b) = b == x || a == y +-- +-- +--combineListsWithID :: Eq a => [[a]] -> [[a]] +--combineListsWithID (x: From 29e7909db272a1d083c8a711ffe7724292ea7bdf Mon Sep 17 00:00:00 2001 From: jgk Date: Sat, 3 Apr 2021 00:30:10 +0200 Subject: [PATCH 04/13] Add haddock comments --- src/Loop.hs | 68 ++++++++++++++++++++++++++++------------------------- 1 file changed, 36 insertions(+), 32 deletions(-) diff --git a/src/Loop.hs b/src/Loop.hs index 0f087c304..4ed1f8e0c 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -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 + } + From d65b099c0df13616f2dd249a45bb14376fa7dcb9 Mon Sep 17 00:00:00 2001 From: jgk Date: Sat, 3 Apr 2021 12:14:53 +0200 Subject: [PATCH 05/13] Modularise graph functions --- src/Dodge/Graph.hs | 21 +++++++++++++++++++++ src/Dodge/Layout.hs | 2 +- src/Dodge/Path.hs | 10 +--------- test/Spec.hs | 2 ++ 4 files changed, 25 insertions(+), 10 deletions(-) create mode 100644 src/Dodge/Graph.hs diff --git a/src/Dodge/Graph.hs b/src/Dodge/Graph.hs new file mode 100644 index 000000000..02ad7192e --- /dev/null +++ b/src/Dodge/Graph.hs @@ -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 diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index e421ed7c5..202859817 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -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 diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index ae168e341..586cdb73f 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -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 -> [] - diff --git a/test/Spec.hs b/test/Spec.hs index cd4753fc9..cf937348d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,4 @@ +import Test.QuickCheck + main :: IO () main = putStrLn "Test suite not yet implemented" From d1586472735368ab555f0424ddf9b828c5e71d89 Mon Sep 17 00:00:00 2001 From: jgk Date: Sat, 3 Apr 2021 12:18:22 +0200 Subject: [PATCH 06/13] Add QuickCheck dep --- package.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/package.yaml b/package.yaml index 17b7c70f9..38619ba3f 100644 --- a/package.yaml +++ b/package.yaml @@ -46,6 +46,7 @@ dependencies: - linear - aeson - directory +- QuickCheck library: source-dirs: src From 9372db9cdcb32de61ea3d3deba58dbce8876f83b Mon Sep 17 00:00:00 2001 From: jgk Date: Sat, 3 Apr 2021 12:18:43 +0200 Subject: [PATCH 07/13] Create file --- src/Dodge/Layout/LockAndKey.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 src/Dodge/Layout/LockAndKey.hs diff --git a/src/Dodge/Layout/LockAndKey.hs b/src/Dodge/Layout/LockAndKey.hs new file mode 100644 index 000000000..f20b25052 --- /dev/null +++ b/src/Dodge/Layout/LockAndKey.hs @@ -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 From 3a1b15aced79ce5e765a65f4c4b4451116040bba Mon Sep 17 00:00:00 2001 From: jgk Date: Sat, 3 Apr 2021 13:43:56 +0200 Subject: [PATCH 08/13] Setup basic tests for wall carving --- src/Dodge/LevelGen/StaticWalls.hs | 2 ++ test/Spec.hs | 34 ++++++++++++++++++++++++++++++- 2 files changed, 35 insertions(+), 1 deletion(-) diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index aa307d422..6ec629ffc 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -48,6 +48,8 @@ checkWallLeft (x,y) wls = case filter (\(a,b) -> b == x ) wls of -- 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 cutWalls' :: [Point2] -> [WallP] -> [WallP] +cutWalls' [] walls = walls +cutWalls' [x,y] walls = walls cutWalls' qs walls = -- nub -- . filter (not.wallIsZeroLength) diff --git a/test/Spec.hs b/test/Spec.hs index cf937348d..55b42155a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,36 @@ 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 + +polygonStrictlyConvex :: [Point2] -> Bool +polygonStrictlyConvex ps = True + +--prop_looping :: [Point2] -> [WallP] -> Bool + +prop_looping = forAllShrink genTris shrinkTris $ \tris -> + isLooping $ foldr cutWalls' [] tris + +shrinkTris (x:xs) = xs : map (x :) (shrink xs) + +genTri = zip <$> trip <*> trip + where + trip = vectorOf 3 $ choose (-500,500::Float) + +genTris = listOf genTri + +--extractLoops :: Eq a => [(a,a)] -> [[(a,a)]] +--extractLoops [] = [] +--extractLoops (x:xs) = + From 1b6b89f4d79aea58776f2c3482b507830a98e80b Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 4 Apr 2021 14:06:56 +0200 Subject: [PATCH 09/13] Partial fix to static wall generation, add haddocks --- src/Dodge/LevelGen/StaticWalls.hs | 130 ++++++++++++++++++------------ src/Geometry.hs | 8 -- test/Spec.hs | 27 ++++++- 3 files changed, 103 insertions(+), 62 deletions(-) diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 6ec629ffc..438fe4aa7 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -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 @@ -19,7 +23,8 @@ 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. cutWalls :: [Point2] -> [WallP] -> [WallP] cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of [] -> newWalls @@ -36,20 +41,40 @@ 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. +-- Unclear behaviour if a line in the polygon is colinear with a wall. cutWalls' :: [Point2] -> [WallP] -> [WallP] -cutWalls' [] walls = walls -cutWalls' [x,y] walls = walls cutWalls' qs walls = -- nub -- . filter (not.wallIsZeroLength) @@ -64,18 +89,15 @@ 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 +-- unused steps: -- 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 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 @@ -84,12 +106,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)] @@ -98,60 +120,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 @@ -161,13 +186,16 @@ fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws 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 (0.5 *.* (fst wall +.+ snd wall)) ps --- 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 +hw x y = 0.5 *.* (x +.+ y) --pairElems :: Eq a => [(a,a)] -> [a] diff --git a/src/Geometry.hs b/src/Geometry.hs index 0c8614ad6..630a19921 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -57,14 +57,6 @@ 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 - - errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool errorPointInPolygon !i !p xs | length xs == 1 = error "one point polygon" diff --git a/test/Spec.hs b/test/Spec.hs index 55b42155a..1344baae1 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -14,19 +14,34 @@ 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 -> - isLooping $ foldr cutWalls' [] tris + (all (not . (\[a,b,c] -> isOnLine a b c + || isOnLine a c b + || isOnLine b c a + ) ) tris) + ==> (isLooping' $ foldr cutWalls' [] tris) -shrinkTris (x:xs) = xs : map (x :) (shrink xs) +shrinkTris [] = [] +shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs) genTri = zip <$> trip <*> trip where - trip = vectorOf 3 $ choose (-500,500::Float) + trip = vectorOf 3 $ fmap fromIntegral $ choose (0,5::Int) genTris = listOf genTri @@ -34,3 +49,9 @@ genTris = listOf genTri --extractLoops [] = [] --extractLoops (x:xs) = +--[[(4.0,10.0),(6.0,2.0),(3.0,0.0)],[(9.0,3.0),(2.0,5.0),(0.0,6.0)]] +-- +--[[(314.0,-396.0),(0.0,-223.71985),(-239.32773,357.25983)],[(0.0,0.0),(-84.0,-177.0),(237.0,-355.5366)]] +-- +-- +--[[(5.0,2.0),(3.0,5.0),(1.0,2.0)],[(3.0,2.0),(2.0,0.0),(4.0,0.0)],[(5.0,1.0),(3.0,0.0),(3.0,1.0)]] From b218c9f29830efa56f5647cd0d3313c41272bcc4 Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 4 Apr 2021 14:53:23 +0200 Subject: [PATCH 10/13] Hack fix to wall carving, expand polygon and retry if first cut fails --- src/Dodge/Floor.hs | 68 +++++++++++++++---------------- src/Dodge/LevelGen/StaticWalls.hs | 35 ++++++++++++---- test/Spec.hs | 8 +--- 3 files changed, 63 insertions(+), 48 deletions(-) diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index e6f7b366c..60008b30a 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -36,41 +36,41 @@ lev1 = do ++ [return $ connectRoom corridor ,return $ connectRoom door ,glassSwitchBack >>= randomiseLinks] --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door] --- ++ [miniRoom3] --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door] --- ++ [roomCCrits] --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door] --- ++[roomMiniIntro] --- ++ [longRoom >>= randomiseLinks] --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++ [miniRoom3] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++ [roomCCrits] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++[roomMiniIntro] + ++ [longRoom >>= randomiseLinks] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] ++ firstWeapon --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door] --- ++ [randomiseLinks =<< pistolerRoom] --- ++ [return $ connectRoom door] --- ++ [randomiseLinks =<< shooterRoom] --- ++ (replicate 3 $ randomiseLinks corridor) --- ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] --- ++ [return $ connectRoom corridor] --- ++ (replicate 3 $ randomiseLinks corridor) --- ++ [return $ connectRoom corridor] --- ++[return $ connectRoom corridor,return $ connectRoom door] --- ++ [shootingRange] --- ++ (replicate 3 $ randomiseLinks corridor) --- ++[roomMiniIntro] --- ++ (replicate 3 $ randomiseLinks corridor) --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door --- ,slowDoorRoom] --- ++ [return $ connectRoom corridor --- ,spawnerRoom --- ,return $ connectRoom corridor --- ] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++ [randomiseLinks =<< pistolerRoom] + ++ [return $ connectRoom door] + ++ [randomiseLinks =<< shooterRoom] + ++ (replicate 3 $ randomiseLinks corridor) + ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] + ++ [return $ connectRoom corridor] + ++ (replicate 3 $ randomiseLinks corridor) + ++ [return $ connectRoom corridor] + ++[return $ connectRoom corridor,return $ connectRoom door] + ++ [shootingRange] + ++ (replicate 3 $ randomiseLinks corridor) + ++[roomMiniIntro] + ++ (replicate 3 $ randomiseLinks corridor) + ++ [return $ connectRoom corridor + ,return $ connectRoom door + ,slowDoorRoom] + ++ [return $ connectRoom corridor + ,spawnerRoom + ,return $ connectRoom corridor + ] ) $ randomiseLinks corridor diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 438fe4aa7..e689693d3 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -25,8 +25,20 @@ type WallP = (Point2,Point2) -- | 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" @@ -73,13 +85,16 @@ checkWallLeft (x,y) wls -- (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 --- . filter (not.wallIsZeroLength) --- . fuseWallsWith zs - addPolyWalls rs + nub + . filter (not.wallIsZeroLength) + . fuseWallsWith zs + . addPolyWalls rs -- . removeWallsInPolygon ps -- . filter (not.wallIsZeroLength) -- . fuseWallsWith zs @@ -89,10 +104,14 @@ cutWalls' qs walls = (zs,cwals) = cutWallsWithPoints ps walls ps = orderPolygon qs rs = orderPolygon $ nub $ zs ++ qs --- unused steps: --- 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 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: diff --git a/test/Spec.hs b/test/Spec.hs index 1344baae1..e6231f44e 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -41,7 +41,7 @@ shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs) genTri = zip <$> trip <*> trip where - trip = vectorOf 3 $ fmap fromIntegral $ choose (0,5::Int) + trip = vectorOf 3 $ fmap fromIntegral $ choose (0,3::Int) genTris = listOf genTri @@ -49,9 +49,5 @@ genTris = listOf genTri --extractLoops [] = [] --extractLoops (x:xs) = ---[[(4.0,10.0),(6.0,2.0),(3.0,0.0)],[(9.0,3.0),(2.0,5.0),(0.0,6.0)]] -- ---[[(314.0,-396.0),(0.0,-223.71985),(-239.32773,357.25983)],[(0.0,0.0),(-84.0,-177.0),(237.0,-355.5366)]] --- --- ---[[(5.0,2.0),(3.0,5.0),(1.0,2.0)],[(3.0,2.0),(2.0,0.0),(4.0,0.0)],[(5.0,1.0),(3.0,0.0),(3.0,1.0)]] +--[[(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)]] From 12319394824b7e90f627940a667ce1f648dfae71 Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 4 Apr 2021 15:03:59 +0200 Subject: [PATCH 11/13] Cleanup --- src/Dodge/LevelGen/StaticWalls.hs | 17 +---------------- 1 file changed, 1 insertion(+), 16 deletions(-) diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index e689693d3..1817eea71 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -203,6 +203,7 @@ 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. @@ -214,19 +215,3 @@ removeWallsInPolygon ps walls = filter (not . cond) walls -- pointInOrOnPolygon (fst wall) ps -- && pointInOrOnPolygon (snd wall) ps -hw x y = 0.5 *.* (x +.+ y) - - ---pairElems :: Eq a => [(a,a)] -> [a] ---pairElems = concatMap flat2 --- where --- flat2 (x,y) = [x,y] --- ---findLinkedPairs :: Eq a => (a,a) -> [(a,a)] -> [(a,a)] ---findLinkedPairs (x,y) = ( (x,y) : ) . filter f --- where --- f (a,b) = b == x || a == y --- --- ---combineListsWithID :: Eq a => [[a]] -> [[a]] ---combineListsWithID (x: From 3b417c4966d3f26ea4300b94e54ef1a65af9ce20 Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 4 Apr 2021 16:26:06 +0200 Subject: [PATCH 12/13] Add haddocks and/or cleanup --- src/Dodge/Base.hs | 10 +- src/Dodge/Creature/Property.hs | 4 +- src/Dodge/Item/Weapon.hs | 4 +- src/Dodge/Render/Picture.hs | 2 +- src/Dodge/WallCreatureCollisions.hs | 2 +- src/Dodge/WorldEvent.hs | 2 +- src/Dodge/WorldEvent/Flash.hs | 2 +- src/Dodge/WorldEvent/ThingsHit.hs | 4 +- src/Geometry.hs | 254 +++++++++++++++++----------- test/Spec.hs | 6 +- 10 files changed, 174 insertions(+), 116 deletions(-) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 2b9144773..4f75a6cab 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -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 diff --git a/src/Dodge/Creature/Property.hs b/src/Dodge/Creature/Property.hs index c3c1c0196..a85e70050 100644 --- a/src/Dodge/Creature/Property.hs +++ b/src/Dodge/Creature/Property.hs @@ -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) diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 3127a4955..f75dde56f 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -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 diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index e6c2ad832..a1f400d96 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -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 diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index d5685de40..6b2515f14 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -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 diff --git a/src/Dodge/WorldEvent.hs b/src/Dodge/WorldEvent.hs index a09ee41e0..8fc255760 100644 --- a/src/Dodge/WorldEvent.hs +++ b/src/Dodge/WorldEvent.hs @@ -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 diff --git a/src/Dodge/WorldEvent/Flash.hs b/src/Dodge/WorldEvent/Flash.hs index 26171d70c..92a20a694 100644 --- a/src/Dodge/WorldEvent/Flash.hs +++ b/src/Dodge/WorldEvent/Flash.hs @@ -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):_) diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 3360f0b25..9077ec253 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -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 diff --git a/src/Geometry.hs b/src/Geometry.hs index 630a19921..1f2e10cdf 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -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,46 +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]) +-- | Debug version of 'pointInPolygon'. errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool errorPointInPolygon !i !p xs | length xs == 1 = error "one point polygon" @@ -64,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 @@ -109,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 @@ -120,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 @@ -178,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 @@ -209,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 @@ -222,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) @@ -235,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 @@ -250,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 @@ -296,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 @@ -304,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] @@ -327,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 @@ -339,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) ) @@ -371,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 diff --git a/test/Spec.hs b/test/Spec.hs index e6231f44e..dded26738 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -30,9 +30,9 @@ polygonStrictlyConvex ps = True --prop_looping :: [Point2] -> [WallP] -> Bool prop_looping = forAllShrink genTris shrinkTris $ \tris -> - (all (not . (\[a,b,c] -> isOnLine a b c - || isOnLine a c b - || isOnLine b c a + (all (not . (\[a,b,c] -> isOnSeg a b c + || isOnSeg a c b + || isOnSeg b c a ) ) tris) ==> (isLooping' $ foldr cutWalls' [] tris) From 654479da36c61cb16aa38f910e74b35d5f592f67 Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 4 Apr 2021 16:39:58 +0200 Subject: [PATCH 13/13] Cleanup enough to make haddock work --- src/Dodge/AIs.hs | 26 +++++++++++++------------- src/Dodge/Creature.hs | 2 +- src/Dodge/Item/Weapon.hs | 4 ++-- src/Dodge/Layout.hs | 2 +- 4 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/Dodge/AIs.hs b/src/Dodge/AIs.hs index 05813ba79..0824f1058 100644 --- a/src/Dodge/AIs.hs +++ b/src/Dodge/AIs.hs @@ -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 diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index f86a9d483..bcdef972b 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -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 diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index f75dde56f..2fbdaa5d9 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -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 ) diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 202859817..7e2360a98 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -67,7 +67,7 @@ wallsFromTree t = -- createInnerWalls divideWalls . assignKeys - . foldr cutWalls [] -- $ map (map (g . roundPoint2)) + . foldr cutWalls [] -- map (map (g . roundPoint2)) -- . map (map roundPoint2) $ (concatMap _rmPolys $ flatten t) where