Add submodules of levelgen
This commit is contained in:
@@ -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