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

Refactor wall points from lists to pairs

Browse Source
This commit is contained in:
jgk
2021-05-04 01:31:55 +02:00
parent e21178b688
commit 6d4c17fc07
23 changed files with 260 additions and 255 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/LevelGen/AutoDoor.hs
+18 -16
View File
@@ -45,13 +45,13 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr))
(lDoorClosed ++ rDoorClosed)
(map shiftL lDoorClosed ++ map shiftR rDoorClosed)
where
lDoorClosed = [ [pld,hwd]
, [hwd,hwu]
, [hwu,plu]
lDoorClosed = [ (pld,hwd)
, (hwd,hwu)
, (hwu,plu)
]
rDoorClosed = [ [pru,hwu]
, [hwu,hwd]
, [hwd,prd]
rDoorClosed = [ (pru,hwu)
, (hwu,hwd)
, (hwd,prd)
]
norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
hw = 0.5 *.* (pl +.+ pr)
@@ -62,21 +62,23 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr))
prd = pr -.- norm
hwu = hw +.+ norm
hwd = hw -.- norm
shiftL = map $ (+.+ parallel) . (-.- normalizeV parallel)
shiftR = map $ (-.- parallel) . (+.+ normalizeV parallel)
shiftL = h $ (+.+ parallel) . (-.- normalizeV parallel)
shiftR = h $ (-.- parallel) . (+.+ normalizeV parallel)
h func (x,y) = (func x,func y)
addSound (x:xs) = f x : xs
f wl = over doorMech g wl
g dm w | dist wp pld > 2 && dist wp hwd > 2
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
| otherwise = dm w
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
where
wp = snd (_wlLine $ _walls w IM.! (head xs))
autoDoorPane
:: (Point2,Point2) -- ^ Trigger line
-> Int -- ^ Wall id
-> [Point2] -- ^ Closed position
-> [Point2] -- ^ Open position
-> (Point2,Point2) -- ^ Closed position
-> (Point2,Point2) -- ^ Open position
-> Wall
autoDoorPane (trigx,trigy) n closedPos openPos = Door
{ _wlLine = closedPos
@@ -89,17 +91,17 @@ autoDoorPane (trigx,trigy) n closedPos openPos = Door
, _drPositions = DS.singleton closedPos
}
where
a = closedPos !! 0
b = closedPos !! 1
a = fst closedPos
b = snd closedPos
dm w
| any (crNearSeg 40 trigx trigy) $ IM.filter (_crIsAnimate . _crState) $ _creatures w
= flip (foldr changeZonedWall) zoneps $ over walls (IM.adjust openDoor n) w
| otherwise
= flip (foldr changeZonedWall') zoneps $ over walls (IM.adjust closeDoor n) w
mvP !ep !p = mvPointTowardAtSpeed 2 ep p
moveToward :: [Point2] -> Wall -> Wall
moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
in deepseq newPs $ w {_wlLine = newPs}
mvPs (ex,ey) (sx,sy) = (mvP ex sx,mvP ey sy)
moveToward :: (Point2,Point2) -> Wall -> Wall
moveToward (ex,ey) wls = wls & wlLine %~ mvPs (ex,ey)
openDoor = moveToward openPos
closeDoor = moveToward closedPos
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
src/Dodge/LevelGen/Block.hs
+8 -8
View File
@@ -26,7 +26,7 @@ updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) d
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)
(x,y) = zoneOfPoint $ pHalf (fst $ _wlLine bl) (snd $ _wlLine bl)
deadPanes = filter blockIsDead (IM.elems $ _walls w)
deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
blockIsDead wl = case wl ^? blHP of
@@ -38,7 +38,7 @@ killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ w
where
f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
f bl = hitSound' bl
pos = _wlLine bl !! 0
pos = fst $ _wlLine bl
hitSound bl
| _wlIsSeeThrough bl = mkSoundBreakGlass pos
| otherwise = soundMultiFrom sos soundid 25 0
@@ -50,7 +50,7 @@ killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ 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)
let (x,y) = zoneOfPoint $ pHalf (fst $ _wlLine b) (snd $ _wlLine b)
in w & wallsZone . ix x . ix y . ix bid . blVisible %~ const True
& walls . ix bid . blVisible %~ const True
Nothing -> w
@@ -59,7 +59,7 @@ 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
ps = reverse $ orderPolygon $ nub $ concatMap ((\(a,b) -> [a,b]) . _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
@@ -104,7 +104,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w
i = newKey $ _walls w
is = [i.. i + length lines-1]
panes = IM.fromList $ zip is
$ zipWith (\j (a,b) -> Block { _wlLine = [a,b]
$ zipWith (\j (a,b) -> Block { _wlLine = (a,b)
, _wlID = j
, _wlColor = col
, _wlSeen = False
@@ -117,13 +117,13 @@ addBlock (p:ps) hp col isSeeThrough degradability w
}
) is lines
wallInZone wl
| dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
| dist (fst $ _wlLine wl) (snd $ _wlLine wl) <= 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)
(x,y) = zoneOfPoint $ pHalf (fst $ _wlLine wl) (snd $ _wlLine wl)
wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
ips = map zoneOfPoint $ divideLine (2*zoneSize) (fst $ _wlLine wl) (snd $ _wlLine wl)
putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
src/Dodge/LevelGen/InnerWalls.hs
+34 -34
View File
@@ -10,37 +10,37 @@ 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
--createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
--createInnerWalls wls = IM.map (createInnerWall wls) wls
--
--createInnerWall :: IM.IntMap Wall -> Wall -> Wall
--createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR]
-- where wl0 = _wlLine wl !! 0
-- wl1 = _wlLine wl !! 1
-- wlLeft = findWallLeft wl walls
-- wlRight = findWallRight wl walls
-- wlN = normalizeV $ vNormal $ wl1 -.- wl0
-- rN = normalizeV $ vNormal $ (_wlLine wlRight !! 1) -.- (_wlLine wlRight !! 0)
-- lN = normalizeV $ vNormal $ (_wlLine wlLeft !! 1) -.- (_wlLine wlLeft !! 0)
-- wlR = wl0 +.+ 20 *.* normalizeV (wlN +.+ rN)
-- wlL = wl1 +.+ 20 *.* normalizeV (wlN +.+ lN)
--
--findWallLeft :: Wall -> IM.IntMap Wall -> Wall
--findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of
-- [w] -> w
-- wls -> error $ "findWallLeft: " ++ show (map _wlID wls)
-- ++ " wlLines: "++ show (map _wlLine wls)
--
--findWallRight :: Wall -> IM.IntMap Wall -> Wall
--findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of
-- [w] -> w
-- wls -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++
-- show (_wlLine wl) ++ "\nhas a right corner with and only with the walls "
-- ++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls)
-- ++ "\nUnless a wall has a corner with exactly one other wall, there is a problem"
--
--findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
--findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls
--
--findWallsRight :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall
--findWallsRight x wls = IM.filter (\wl -> dist x (_wlLine wl !! 1) < 1) wls
src/Dodge/LevelGen/LineBlock.hs
+15 -12
View File
@@ -34,21 +34,24 @@ putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr i
blockCenPs = snd $ evenOddSplit psOnLine
numBlocks = length blockCenPs
is = [0.. numBlocks - 1]
cornerPoints = [(-halfBlockWidth,-depth) -- goes anticlockwise around the block
,(-halfBlockWidth, depth)
,( halfBlockWidth, depth)
,( halfBlockWidth,-depth)
]
cornerPoints =
[(-halfBlockWidth,-depth) -- goes anticlockwise around the block
,(-halfBlockWidth, depth)
,( halfBlockWidth, depth)
,( halfBlockWidth,-depth)
]
cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
linesAt p = map (\(a,b) -> [a,b]) $ makeLoopPairs $ cornersAt p
linesAt p = map (\(a,b) -> (a,b)) $ makeLoopPairs $ cornersAt p
k = newKey $ _walls w
ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
visibilityAt i | i == 0 = [ True,True,False,True]
| i == numBlocks - 1 = [False,True, True,True]
| otherwise = [False,True,False,True]
shadowsAt i | i == 0 = ksAtI 1
| i == numBlocks - 1 = ksAtI $ numBlocks - 2
| otherwise = ksAtI (i-1) ++ ksAtI (i+1)
visibilityAt i
| i == 0 = [ True,True,False,True]
| i == numBlocks - 1 = [False,True, True,True]
| otherwise = [False,True,False,True]
shadowsAt i
| i == 0 = ksAtI 1
| i == numBlocks - 1 = ksAtI $ numBlocks - 2
| otherwise = ksAtI (i-1) ++ ksAtI (i+1)
makeBlockAt :: Point2 -> Int -> [Wall]
makeBlockAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
makePane i visStatus k' ps
src/Dodge/LevelGen/TriggerDoor.hs
+26 -25
View File
@@ -87,12 +87,12 @@ mkTriggerDoor
mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $
transpose $ map toPanePoints ppairs
toPanePoints :: (Point2,Point2) -> [[Point2]]
toPanePoints :: (Point2,Point2) -> [(Point2,Point2)]
toPanePoints (x,y) =
[ [y +.+ perp, y -.- perp]
, [y -.- perp, x -.- perp]
, [x -.- perp, x +.+ perp]
, [x +.+ perp, y +.+ perp]
[ (y +.+ perp, y -.- perp)
, (y -.- perp, x -.- perp)
, (x -.- perp, x +.+ perp)
, (x +.+ perp, y +.+ perp)
]
where
perp = 9 *.* errorNormalizeV 49 ( vNormal (x -.- y))
@@ -104,19 +104,20 @@ mkTriggerDoubleDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPaneLinear
(map shiftLeft leftDoor ++ map shiftRight rightDoor)
where
leftDoor =
[ [pld +.+ perp,hwd]
, [hwd, hwu]
, [hwu, plu +.+ perp]
, [plu +.+ perp,pld +.+ perp]
[ (pld +.+ perp,hwd)
, (hwd, hwu)
, (hwu, plu +.+ perp)
, (plu +.+ perp,pld +.+ perp)
]
rightDoor =
[ [pru -.- perp,hwu]
, [hwu, hwd]
, [hwd, prd -.- perp]
, [prd -.- perp,pru -.- perp]
[ (pru -.- perp,hwu)
, (hwu, hwd)
, (hwd, prd -.- perp)
, (prd -.- perp,pru -.- perp)
]
shiftRight = map (+.+ (0.5 *.* (pr -.- pl)))
shiftLeft = map (+.+ (0.5 *.* (pl -.- pr)))
shiftRight = h (+.+ (0.5 *.* (pr -.- pl)))
shiftLeft = h (+.+ (0.5 *.* (pl -.- pr)))
h func (x,y) = (func x,func y)
norm = 9 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
hw = 0.5 *.* (pl +.+ pr)
perp = 5 *.* normalizeV (pl -.- pr)
@@ -133,14 +134,14 @@ mkTriggerDoubleDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPaneLinear
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
| otherwise = dm w
where
wp = _wlLine (_walls w IM.! head xs) !! 1
wp = snd $ _wlLine (_walls w IM.! head xs)
triggerDoorPaneLinear
:: Color
-> (World -> Bool) -- ^ Opening condition
-> Int -- ^ Wall id
-> [Point2] -- ^ Closed position
-> [Point2] -- ^ Open position
-> (Point2,Point2) -- ^ Closed position
-> (Point2,Point2) -- ^ Open position
-> Wall
triggerDoorPaneLinear c cond n closedPos openPos = Door
{ _wlLine = closedPos
@@ -153,8 +154,8 @@ triggerDoorPaneLinear c cond n closedPos openPos = Door
, _drPositions = DS.singleton closedPos
}
where
a = closedPos !! 0
b = closedPos !! 1
a = fst closedPos
b = snd closedPos
dm w | cond w = flip (foldr changeZonedWall) zoneps
$ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
| otherwise = flip (foldr changeZonedWall') zoneps
@@ -162,9 +163,9 @@ triggerDoorPaneLinear c cond n closedPos openPos = Door
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
mvP !ep !p = mvPointTowardAtSpeed 2 ep p
moveToward :: [Point2] -> Wall -> Wall
moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
in deepseq newPs $ w {_wlLine = newPs}
mvPs (ex,ey) (sx,sy) = (mvP ex sx,mvP ey sy)
moveToward :: (Point2,Point2) -> Wall -> Wall
moveToward (ex,ey) wls = wls & wlLine %~ mvPs (ex,ey)
openDoor = moveToward openPos
closeDoor = moveToward closedPos
changeZonedWall (!x,!y)
@@ -179,7 +180,7 @@ triggerDoorPane
:: Color
-> (World -> Bool) -- ^ Opening condition
-> Int -- ^ Wall id
-> [[Point2]] -- ^ List of positions: closed to open
-> [(Point2,Point2)] -- ^ List of positions: closed to open
-> Wall
triggerDoorPane c cond n poss = Door
{ _wlLine = head poss
@@ -205,6 +206,6 @@ triggerDoorPane c cond n poss = Door
changeZonedWall' (!x,!y)
= over wallsZone $ adjustIMZone closeDoor x y n
allZoneps = nub $ concatMap zoneps poss
zoneps [a,b]
zoneps (a,b)
| dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b