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

Start refactoring levelGen

Browse Source
This commit is contained in:
justin
2021-03-04 14:44:12 +01:00
parent 8ed8c48ffe
commit b8c84b84f0
4 changed files with 100 additions and 122 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/LevelGen.hs
+28 -32
View File
@@ -31,19 +31,10 @@ import Data.Graph.Inductive.NodeMap
import Data.Tree
-- }}}
inSegSeg 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)
--
--supposes that the quadrilateral points are given in anticlockwise order
-- cutOutQuad :: Point -> Point -> Point -> Point -> IM.IntMap Wall -> IM.IntMap Wall
-- cutOutQuad p1 p2 p3 p4 walls = cutLine p4 p1 . cutLine p3 p4 . cutLine p2 p3 . cutLine p1 p2 $ walls
collidePointAllWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
collidePointAllWalls p1 p2 walls = IM.filter f walls
where f wall
@@ -52,7 +43,6 @@ collidePointAllWalls p1 p2 walls = IM.filter f walls
_ -> True
-- returns walls that collide with lines, and the point of collision
collidePointAllWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,Point2)
collidePointAllWallsPoints p1 p2 walls = IM.mapMaybe f walls
where f wall
@@ -108,20 +98,17 @@ pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV
s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs)))
-.- p
-- ok, now to find out which new walls need to be drawn
drawCutWall :: (Point2, Point2) -> IM.IntMap Wall -> IM.IntMap Wall
drawCutWall (p1,p2) walls =
case maybeW of Just w -> if errorIsLHS 200 (_wlLine w !! 0) (_wlLine w !! 1) p3
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 = case IM.lookupMax walls
of Nothing -> 0
Just (j,_) -> j + 1
k = newKey walls
newWall = basicWall {_wlLine = [p1,p2], _wlID = k}
@@ -157,40 +144,47 @@ intersectSegPoint s1 s2 p = if isOnLine s1 s2 p then Just p else Nothing
-- new procedure: line by line
-- then remove all walls inside the polygon
-- abuses the list nature of wlLine
cutWall1 :: Point2 -> Point2 -> Wall -> Wall
cutWall1 p1 p2 wall = case maybeCP of
-- 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
w0' = w0 +.+ normalizeV (w0 -.- w1)
w1' = w1 +.+ normalizeV (w1 -.- w0)
p1' = p1 +.+ normalizeV (p1 -.- p2)
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)
pT = p1' +.+ vNormal (normalizeV (p1 -.- p2))
pB = p1' -.- vNormal (normalizeV (p1 -.- p2))
--maybeCP = intersectSegSeg p1' p2' w0' w1'-- <|> intersectSegSeg w0 w1 pT pB
--maybeCP = inSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB
maybeCP = inSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB
--maybeCP = intersectSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB
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
cutWalls1 :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
cutWalls1 p1 p2 ws = foldr splitAndAdd ws $ IM.map (cutWall1 p1 p2) ws
where splitAndAdd w ws
cutWalls1 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 = map head $ filter (\xs -> length xs > 2)
$ IM.elems $ IM.map (_wlLine . cutWall1 p1 p2) ws
$ IM.elems $ IM.map (_wlLine . cutWall p1 p2) ws
-- given a polygon expressed as a list of points and a collection of walls,
-- gives a pair containing fst: points of the polygon and its intersection with walls
-- snd: the collection of walls cut by the polygon
cutWallsProcess :: [Point2] -> IM.IntMap Wall -> ([Point2], IM.IntMap Wall)
cutWallsProcess (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
where f (p1,p2) (as,ws') = (as ++ cutWallsPoints p1 p2 ws', cutWalls1 p1 p2 ws')
where f (p1,p2) (as,ws') = (as ++ cutWallsPoints p1 p2 ws'
, cutWalls1 p1 p2 ws')
cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
cutWalls qs walls = -- IM.filter (not . wallIsZeroLength) $ fuseWalls $
@@ -226,6 +220,7 @@ fuseWalls :: IM.IntMap Wall -> IM.IntMap Wall
fuseWalls ws = snd $ IM.foldr fuseWalls' ([], IM.empty) ws
where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w)
in (qs, IM.insert (_wlID w') w' ws)
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)
@@ -665,7 +660,8 @@ autoDoorPane trigL n [a,b] [a',b'] = AutoDoor
, _wlID = n
, _doorMech = dm
, _wlColor = dim $ yellow
, _wlDraw = Just drawAutoDoor
-- , _wlDraw = Just drawAutoDoor
, _wlDraw = Nothing
, _wlSeen = False
, _wlIsSeeThrough = False
-- , _doorLine = [a,b,a',b']