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

General improvement to shadows

Browse Source
This commit is contained in:
jgk
2021-03-06 12:23:19 +01:00
parent 079f4deecf
commit d57bfcf354
4 changed files with 79 additions and 28 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+1
View File
@@ -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
src/Dodge/LevelGen.hs
+6 -23
View File
@@ -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
src/Dodge/LevelGen/Block.hs
+49 -1
View File
@@ -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
src/Dodge/Rooms.hs
+23 -4
View File
@@ -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)