Add submodules of levelgen
This commit is contained in:
@@ -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)
|
||||||
|
|
||||||
@@ -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
|
||||||
Reference in New Issue
Block a user