From 079f4deecf2773959e3b1deee16e5da35fa680b7 Mon Sep 17 00:00:00 2001 From: jgk Date: Fri, 5 Mar 2021 20:25:25 +0100 Subject: [PATCH] Add submodules of levelgen --- src/Dodge/LevelGen/Block.hs | 105 ++++++++++++++++ src/Dodge/LevelGen/StaticWalls.hs | 199 ++++++++++++++++++++++++++++++ 2 files changed, 304 insertions(+) create mode 100644 src/Dodge/LevelGen/Block.hs create mode 100644 src/Dodge/LevelGen/StaticWalls.hs diff --git a/src/Dodge/LevelGen/Block.hs b/src/Dodge/LevelGen/Block.hs new file mode 100644 index 000000000..3dd44f0d6 --- /dev/null +++ b/src/Dodge/LevelGen/Block.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE BangPatterns #-} +module Dodge.LevelGen.Block where +import Dodge.Data +import Dodge.Base +import Dodge.SoundLogic + +import Geometry +import Picture.Data + +import Control.Lens + +import Data.List + +import Data.Function +import qualified Data.IntMap.Strict as IM +import System.Random +import Control.Monad.State + +updateBlocks :: World -> World +updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) deadPanes + $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls) + degradeBlocks +-- w + where degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks + removeFromZone :: Wall -> World -> World + removeFromZone bl = over (wallsZone . ix x . ix y) (IM.delete (_wlID bl)) + where (x,y) = zoneOfPoint $ pHalf (_wlLine bl !! 0) (_wlLine bl !! 1) + deadPanes = filter blockIsDead (IM.elems $ _walls w) + deadBlocks = nubBy ((==) `on` _blIDs) deadPanes + blockIsDead wl = case wl ^? blHP of Just x -> x <= 0 + Nothing -> False + +killBlock :: Wall -> World -> World +killBlock bl w = f bl . + flip (foldr unshadow) +-- flip (foldr (\i -> set (walls . ix i . blVisible) (True))) + (_blShadows bl) + $ w + where + f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl + f bl = hitSound' bl + hitSound bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+8) 25 0 + | otherwise = soundMultiFrom sos soundid 25 0 + hitSound' bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+4) 25 0 + | otherwise = soundMultiFrom sos soundid 25 0 + sos = [BlockDegradeSound 0,BlockDegradeSound 1] + (soundid,_) = randomR (29,32) $ _randGen w + unshadow :: Int -> World -> World + unshadow bid w = case w ^? walls . ix bid of + Just b -> let (x,y) = zoneOfPoint $ pHalf (_wlLine b !! 0) (_wlLine b !! 1) + in w & wallsZone . ix x . ix y . ix bid . blVisible %~ \_ -> True + Nothing -> w + +degradeBlock :: Wall -> World -> World +degradeBlock bl w = let blid = _wlID bl + bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid) + ps = reverse $ orderPolygon $ nub $ concatMap _wlLine bls + (newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w + (x:xs) = _blDegrades bl + in addBlock newPs (x + _blHP bl) (_wlColor bl) (_wlIsSeeThrough bl) xs $ set randGen g w + +pushPointTowardsBy :: RandomGen g => Float -> Point2 -> [Point2] -> State g Point2 +pushPointTowardsBy x p ps = do + xs <- sequence $ take (length ps) $ repeat $ state $ randomR (0, x / (fromIntegral $ length ps)) + let toAdd p' y = y *.* (p' -.- p) + return $ p +.+ foldr1 (+.+) (zipWith toAdd ps xs) + +shrinkPolygon :: RandomGen g => Float -> [Point2] -> State g [Point2] +shrinkPolygon x ps = sequence $ map (flip (pushPointTowardsBy x) ps) ps + + +addBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World +addBlock (p:ps) hp col isSeeThrough degradability w + | hp <= 0 && degradability == [] = w + | hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w + | otherwise = over wallsZone (flip (IM.foldr wallInZone) blocks) + $ over walls (IM.union blocks) w +--addBlock (p:p':ps) w = over walls (IM.insert i b) w + where + lines = zip (p:ps) (ps ++ [p]) + i = newKey $ _walls w + is = [i.. i + length lines-1] + blocks = IM.fromList $ zip is + $ zipWith (\j (a,b) -> Block { _wlLine = [a,b] + , _wlID = j + -- , _wlColor = greyN 0.5 + , _wlColor = col + , _wlDraw = Nothing + , _wlSeen = False + , _blIDs = is + , _blHP = hp + , _wlIsSeeThrough = isSeeThrough + , _blVisible = True + , _blShadows = [] + , _blDegrades = degradability + , _wlCastShadow = False + } + ) is lines + wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize + = insertIMInZone x y wlid wl + | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips + where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1)) + wlid = _wlID wl + ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1) + diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs new file mode 100644 index 000000000..eb0b77d20 --- /dev/null +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -0,0 +1,199 @@ +module Dodge.LevelGen.StaticWalls + where +import Dodge.Data +import Dodge.Base +import Dodge.Prototypes + +import Geometry + +import Control.Lens + +import Data.Function (on) + +import Data.List +import Data.Maybe +import qualified Data.IntMap as IM + +import qualified Data.Set as S + +-- 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] -> IM.IntMap Wall -> IM.IntMap Wall +cutWalls qs walls = createPolyWalls rs + . IM.filter (not.wallIsZeroLength) + . removeWallsInPolygon ps + $ fuseWallsWith zs cwals + where (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) +-- fuse wall endpoints that end up close to each or to polygon intersection points +-- remove the created walls that are inside the polygon +-- also remove any walls that ended up zero length +-- draw the required new walls along the polygon boundary + +createPolyWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall +createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q])) + +-- creates 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 +createPolyWall :: (Point2, Point2) -> IM.IntMap Wall -> IM.IntMap Wall +createPolyWall (p1,p2) walls = + case maybeW of Just w -> if isLHS (_wlLine w !! 0) (_wlLine w !! 1) p3 + then walls + else IM.insert k newWall walls + Nothing -> IM.insert k newWall walls + where p3 = 0.5 *.* (p1 +.+ p2) + p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1) + maybeW = wallOnLine p3 p4 walls + k = newKey walls + newWall = basicWall {_wlLine = [p1,p2], _wlID = k} + +-- given a segment and a wall, adds a cut point to the wall if it intersects the +-- segment +cutWall :: Point2 -> Point2 -> Wall -> Wall +cutWall p1 p2 wall = case maybeCP of + Nothing -> wall + Just cp -> wall {_wlLine = [cp,w0,w1]} + where wl = _wlLine wall + w0 = wl !! 0 + w1 = wl !! 1 + maybeCP = intersectExtendedSegSeg p1 p2 w0 w1 + +-- 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 segment and a collection of walls, cuts each wall where it intersects +-- with the segment, adds the two cut walls +addCutWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall +addCutWalls p1 p2 ws = foldr addTwoWallsIfCut ws $ IM.map (cutWall p1 p2) ws + where addTwoWallsIfCut w ws + = case _wlLine w of + (cp:w0:w1:[]) -> IM.insert (newKey ws) (w {_wlLine = [cp,w1] + ,_wlID = newKey ws}) + $ IM.insert (_wlID w) (w {_wlLine = [w0,cp]}) ws + (x:y:[]) -> ws + +-- lists the points of intersection between a segment and collection of walls +cutWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> [Point2] +cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y) + $ map _wlLine $ IM.elems ws + +-- 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] -> IM.IntMap Wall -> ([Point2], IM.IntMap Wall) +cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p])) + where f (p1,p2) (as,ws') = ( as ++ cutWallsPoints p1 p2 ws' + , addCutWalls p1 p2 ws' + ) + + +-- given a list of points and a point, returns a point in the list if any is close +-- enough to the point +findClosePoint :: [Point2] -> Point2 -> Maybe Point2 +findClosePoint ps p = find (\q -> dist p q < 5) ps + +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 +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 +fuseWall :: ([Point2], Wall) -> ([Point2], Wall) +fuseWall (ps, w) = ( rs + , w Control.Lens.& wlLine .~ [w0,w1] + ) + where qs = catMaybes [pointIfNotClose ps (_wlLine w !! 0)] ++ ps + rs = catMaybes [pointIfNotClose qs (_wlLine w !! 1)] ++ qs + w0 = fusePoint ps (_wlLine w !! 0) + w1 = fusePoint qs (_wlLine w !! 1) + +-- 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] -> IM.IntMap Wall -> IM.IntMap Wall +fuseWallsWith zs ws = snd $ IM.foldr fuseWalls' (zs, IM.empty) ws + where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w) + in (qs, IM.insert (_wlID w') w' ws) + +wallIsZeroLength w = l !! 0 == l !! 1 + where l = _wlLine w + +wallLengthGT x w = dist (l !! 0) (l !! 1) > x + where l = _wlLine w + +removeWallsInPolygon :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall +removeWallsInPolygon ps walls = IM.filter (not . cond) walls + where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps + && pointInsidePolygon (_wlLine wall !! 1) ps + +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 +------------------------------------------------------ +finalFuse :: IM.IntMap Wall -> IM.IntMap Wall +finalFuse = IM.filter (not.wallIsZeroLength) . fuseWallsWith [] + +------------------------------------------------------ + +nubWalls :: IM.IntMap Wall -> IM.IntMap Wall +nubWalls wls = IM.fromList $ nubBy ((==) `on` _wlLine . snd) $ IM.assocs wls + +checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall +checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of + Just wl -> error $ show $ _wlLine wl + _ -> wls + +checkWalls wls | (nub $ map _wlLine $ IM.elems wls) + == (map _wlLine $ IM.elems wls) = wls + | otherwise = error "hasdup" + +-- 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 %~ (++) [(0,0)] +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: is there a standalone wall? wlIDs: " ++ 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: is there a standalone wall? wlIDs: " ++ show (map _wlID wls) + ++ " wlLines: "++ show (map _wlLine wls) + +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