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