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

Add no weapon start

Browse Source
This commit is contained in:
jgk
2021-04-27 19:26:35 +02:00
parent 64b5b9e2a5
commit 6d229f8de2
20 changed files with 448 additions and 313 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/LevelGen/Pathing.hs
+4 -4
View File
@@ -23,7 +23,7 @@ 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'
where
pg' = filter (isNothing . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
newGraph = pairsToGraph dist pg'
src/Dodge/LevelGen/StaticWalls.hs
+11 -17
View File
@@ -35,26 +35,26 @@ nearCollinear (a,b) (x,y)
-- | Remove inverse walls.
removeInverseWalls :: [WallP] -> [WallP]
removeInverseWalls ((a,b):ps)
| elem (b,a) ps = removeInverseWalls $ delete (b,a) ps
| otherwise = (a,b) : (removeInverseWalls ps)
| (b,a) `elem` ps = removeInverseWalls $ delete (b,a) ps
| otherwise = (a,b) : removeInverseWalls ps
removeInverseWalls ps = ps
-- | 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
cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
[] -> newWalls
_ -> cutWalls (expandPolyBy 0.01 ps) wls
where
newWalls = cutWalls' ps wls
errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
errsL = mapMaybe (`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
cutWalls'' ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
[] -> newWalls
errs -> error $ "during level generation function cutWalls: when cutting poly:\n" ++ show ps
++ "\nRight corner errors:\n"
@@ -67,7 +67,7 @@ cutWalls'' ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
++ unlines (map show newWalls)
where
newWalls = cutWalls' ps wls
errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
errsL = mapMaybe (`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
@@ -126,7 +126,7 @@ cutWalls' qs walls =
expandPolyBy :: Float -> [Point2] -> [Point2]
expandPolyBy x ps = map f ps
where
cp = (1/(fromIntegral (length ps))) *.* (foldr (+.+) (0,0) ps)
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,
@@ -144,7 +144,7 @@ cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
-- | 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
cutWallsPoints p1 p2 = mapMaybe (uncurry $ myIntersectSegSeg p1 p2)
-- | Given a segment and a wall, split the wall into two if it crosses the segment.
cutWall :: Point2 -> Point2 -> WallP -> [WallP]
@@ -171,9 +171,7 @@ addPolyWall (p1,p2) walls =
where
p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
maybeWs = -- listToMaybe .
fmap (fst . unzip)
-- . fmap unzip
maybeWs = fmap (map fst)
. listToMaybe
$ groupBy ((==) `on` (dist p3 . snd))
wlsP
@@ -224,10 +222,6 @@ 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
removeWallsInPolygon ps = filter (not . cond)
where
cond wall =
pointInOrOnPolygon (0.5 *.* (fst wall +.+ snd wall)) ps
-- pointInOrOnPolygon (fst wall) ps
-- && pointInOrOnPolygon (snd wall) ps
cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
src/Dodge/LevelGen/Switch.hs
+31 -27
View File
@@ -29,10 +29,14 @@ makeButton c eff = Button
, _btState = BtOff
}
where
turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = const id}
onPict = onLayer WlLayer (color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
makeSwitch :: Color -> (World -> World) -> (World -> World) -> Button
makeSwitch
:: Color
-> (World -> World) -- ^ Switch on effect
-> (World -> World) -- ^ Switch off effect
-> Button
makeSwitch c effOn effOff = Button
{ _btPict = offPict
, _btPos = (0,0)
@@ -42,28 +46,28 @@ makeSwitch c effOn effOff = Button
, _btText = "SWITCH/"
, _btState = BtOff
}
where
flipSwitch b w = switchEffect b . soundOnce 1 $ w
switchEffect b = case _btState b of
BtOff -> effOn . over buttons (IM.adjust turnOn (_btID b))
BtOn -> effOff . over buttons (IM.adjust turnOff (_btID b))
offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) (10)
,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
]
onPict = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) (10)
,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
]
turnOn :: Button -> Button
turnOn bt = bt
{ _btState = BtOn
, _btPict = onPict
, _btText = "SWITCH\\"
}
turnOff :: Button -> Button
turnOff bt = bt
{ _btState = BtOff
, _btPict = offPict
, _btText = "SWITCH/"
}
where
flipSwitch b w = switchEffect b . soundOnce 1 $ w
switchEffect b = case _btState b of
BtOff -> effOn . over buttons (IM.adjust turnOn (_btID b))
BtOn -> effOff . over buttons (IM.adjust turnOff (_btID b))
offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) 10
,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
]
onPict = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) 10
,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
]
turnOn :: Button -> Button
turnOn bt = bt
{ _btState = BtOn
, _btPict = onPict
, _btText = "SWITCH\\"
}
turnOff :: Button -> Button
turnOff bt = bt
{ _btState = BtOff
, _btPict = offPict
, _btText = "SWITCH/"
}
src/Dodge/LevelGen/TriggerDoor.hs
+7 -7
View File
@@ -88,7 +88,7 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
]
shiftRight = map (+.+ (0.5 *.* (pr -.- pl)))
shiftLeft = map (+.+ (0.5 *.* (pl -.- pr)))
norm = 14 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
norm = 9 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
hw = 0.5 *.* (pl +.+ pr)
perp = 5 *.* normalizeV (pl -.- pr)
plu = pl +.+ norm
@@ -99,12 +99,12 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
hwd = hw -.- norm
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
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
triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
triggerDoorPane c cond n closedPos openPos = Door