From d57bfcf35456483b094bd37ac42af410034e3386 Mon Sep 17 00:00:00 2001 From: jgk Date: Sat, 6 Mar 2021 12:23:19 +0100 Subject: [PATCH] General improvement to shadows --- src/Dodge/Data.hs | 1 + src/Dodge/LevelGen.hs | 29 +++++---------------- src/Dodge/LevelGen/Block.hs | 50 ++++++++++++++++++++++++++++++++++++- src/Dodge/Rooms.hs | 27 +++++++++++++++++--- 4 files changed, 79 insertions(+), 28 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 7e38db3b1..d7a3d12c3 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -623,6 +623,7 @@ data PSType = PutCrit Creature | PutPressPlate PressPlate | PutAutoDoor Point2 Point2 | PutBlock [Int] Color [Point2] + | PutBlockWall [Int] Color [Point2] | PutWindowBlock Point2 Point2 | PutTriggerDoor Color (World -> Bool) Point2 Point2 | PutBtDoor Color Point2 Float Point2 Point2 diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 7bb0846a9..008a939cb 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -6,6 +6,7 @@ module Dodge.LevelGen , createInnerWalls , checkWalls , nubWalls + , pairsToGraph ) where @@ -14,6 +15,7 @@ import Dodge.Base import Dodge.SoundLogic import Dodge.Prototypes import Dodge.LevelGen.Block +import Dodge.LevelGen.Pathing import Dodge.LevelGen.StaticWalls @@ -78,7 +80,10 @@ placeSpot ps w = case ps of -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w PS {_psPos = p, _psRot = rot, _psType = PutBlock (hp:hps) col ps} - -> putBlock (map (shiftPointBy (p,rot)) ps) hp col False hps w + -> putBlock(map (shiftPointBy (p,rot)) ps) hp col False hps w + + PS {_psPos = p, _psRot = rot, _psType = PutBlockWall (hp:hps) col ps} + -> putBlockWallPart (map (shiftPointBy (p,rot)) ps) hp col False hps w PS {_psPos = p, _psRot = rot, _psType = PutBtDoor c bp f a b} -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) @@ -121,10 +126,6 @@ instance Shiftable PlacementSpot where translateS p' (PS p r x) = PS (p +.+ p') r x rotateS r' (PS p r x) = PS (rotateV r' p) (r + r') x -pairsToGraph :: (Ord a, Eq a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b -pairsToGraph f pairs = let nodes = nub (map fst pairs ++ map snd pairs) - pairs' = map (\(x,y)->(x,y,f x y)) pairs - in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes >> insMapEdgesM pairs' makeButton :: Color -> (World -> World) -> Button makeButton c eff = Button @@ -295,24 +296,6 @@ triggerDoorPane c cond n [a,b] [a',b'] = Door addAutoDoor :: Point2 -> Point2 -> World -> World addAutoDoor a b = over walls (autoDoorAt a b) -removePathsCrossing :: Point2 -> Point2 -> World -> World -removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg' - $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) - w - where pg' = filter (not . isJust . uncurry (intersectSegSeg' a b)) $ _pathGraph' w - insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] - newGraph = pairsToGraph dist pg' - -putBlockWallPart :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World -putBlockWallPart (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs - where pairs = zip (p:ps) (ps ++ [p]) - wWithBlock = addBlock (p:ps) i c b is w - -putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World -putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs - where pairs = zip (p:ps) (ps ++ [p]) - wWithBlock = addBlock (p:ps) i c b is w - putWindowBlock :: Point2 -> Point2 -> World -> World putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns where d = dist a b diff --git a/src/Dodge/LevelGen/Block.hs b/src/Dodge/LevelGen/Block.hs index 3dd44f0d6..faf13c96a 100644 --- a/src/Dodge/LevelGen/Block.hs +++ b/src/Dodge/LevelGen/Block.hs @@ -4,6 +4,8 @@ import Dodge.Data import Dodge.Base import Dodge.SoundLogic +import Dodge.LevelGen.Pathing + import Geometry import Picture.Data @@ -68,6 +70,42 @@ pushPointTowardsBy x p ps = do shrinkPolygon :: RandomGen g => Float -> [Point2] -> State g [Point2] shrinkPolygon x ps = sequence $ map (flip (pushPointTowardsBy x) ps) ps +addBlockNoShadow :: [Point2] -> Int -> Color -> Bool -> [Int] -> Bool -> World -> World +addBlockNoShadow (p:ps) hp col isSeeThrough degradability hasAllShadows 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 + shadowList | hasAllShadows = repeat True + | otherwise = concat $ repeat [False,True] + lines = zip (p:ps) (ps ++ [p]) + i = newKey $ _walls w + is = [i.. i + length lines-1] + blocks = IM.fromList $ zip is + $ zipWith3 (\j (a,b) bool + -> 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 = bool + } + ) is lines shadowList + 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) addBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World addBlock (p:ps) hp col isSeeThrough degradability w @@ -93,7 +131,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w , _blVisible = True , _blShadows = [] , _blDegrades = degradability - , _wlCastShadow = False + , _wlCastShadow = True } ) is lines wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize @@ -103,3 +141,13 @@ addBlock (p:ps) hp col isSeeThrough degradability w wlid = _wlID wl ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1) +putBlockWallPart :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World +putBlockWallPart (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs + where pairs = zip (p:ps) (ps ++ [p]) + wWithBlock = addBlockNoShadow (p:ps) i c b is False w + +putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World +putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs + where pairs = zip (p:ps) (ps ++ [p]) + wWithBlock = addBlock (p:ps) i c b is w + diff --git a/src/Dodge/Rooms.hs b/src/Dodge/Rooms.hs index fa354bc16..14ab16370 100644 --- a/src/Dodge/Rooms.hs +++ b/src/Dodge/Rooms.hs @@ -438,19 +438,38 @@ roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treePost g (Node (Right x) xs) = Node (Left x) $ map g xs g (Node y ys) = Node y $ map g ys +putSingleBlock :: Point2 -> [PlacementSpot] +putSingleBlock a = [PS a 0 $ PutBlock [5,20,20] (greyN 0.5) + $ reverse $ rectNSWE 10 (-10) (-10) 10] putWallBlocks :: Point2 -> Point2 -> [PlacementSpot] -putWallBlocks a b = map (\p -> PS p rot $ PutBlock [5,20,20] (greyN 0.5) +putWallBlocks a b = map (\p -> PS p rot $ PutBlockWall [5,20,20] (greyN 0.5) $ reverse $ rectNSWE 10 (-10) (-10) 10) - ps + ps +-- ++ +-- map (\p -> PS p rot $ PutBlockWall [5,20,20] (greyN 0.5) +-- $ reverse $ rectNSWE 10 (-10) (-10) 10) +-- rs + where d = dist a b rot = argV (b -.- a) - numPoints' = floor (d / 20) + numPoints' = floor (d / 30) numPoints = numPoints'*2 + 1 ns = take (numPoints + 1) [0..] ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a)) $ map fromIntegral ns + ps' = map (\i -> au +.+ i/ (fromIntegral numPoints) *.* (bu -.- au)) + $ map fromIntegral ns + rs = map (\i -> ad +.+ i/ (fromIntegral numPoints) *.* (bd -.- ad)) + $ map fromIntegral ns + norm = normalizeV $ vNormal $ b -.- a + au = a +.+ 10 *.* norm + bu = b +.+ 10 *.* norm + ad = a -.- 10 *.* norm + bd = b -.- 10 *.* norm + + roomCenterPillar :: RandomGen g => State g Room roomCenterPillar = changeLinkTo ((\p -> dist p (120,0) < 10) . fst) $ set rmPS plmnts $ roomRect' 240 240 2 2 @@ -809,7 +828,7 @@ shootersRoom = do pistolerRoom :: RandomGen g => State g Room pistolerRoom = do - let f2 x y = putWallBlocks (x,y) (x,y) + let f2 x y = putSingleBlock (x,y) -- let f2 x y = [PS (x,y) 0 $ PutWindow (rectNSEW 40 0 0 40) $ withAlpha 0.5 aquamarine] f3 x y = putWallBlocks (x-20,y) (x+20,y) ++ putWallBlocks (x,y-20) (x,y+20)