Start change of static wall generation to use sets
This commit is contained in:
+3
-1
@@ -65,7 +65,9 @@ makePath :: Tree Room -> [(Point2,Point2)]
|
||||
makePath = concat . map _rmPath . flatten
|
||||
|
||||
wallsFromTree :: Tree Room -> IM.IntMap Wall
|
||||
wallsFromTree t = divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
|
||||
--wallsFromTree t = createInnerWalls $ divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
|
||||
wallsFromTree t = checkWalls $ divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
|
||||
--wallsFromTree t = divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
|
||||
|
||||
divideWall :: Wall -> [Wall]
|
||||
divideWall wl
|
||||
|
||||
+11
-122
@@ -1,6 +1,13 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module Dodge.LevelGen where
|
||||
module Dodge.LevelGen
|
||||
( module Dodge.LevelGen
|
||||
--, module Dodge.LevelGen.StaticWalls
|
||||
, cutWalls
|
||||
, createInnerWalls
|
||||
, checkWalls
|
||||
)
|
||||
where
|
||||
-- imports {{{
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
@@ -8,14 +15,13 @@ import Dodge.SoundLogic
|
||||
import Dodge.Prototypes
|
||||
import Dodge.Block
|
||||
|
||||
import Dodge.LevelGen.StaticWalls
|
||||
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
import System.Random
|
||||
--import Graphics.Gloss
|
||||
--import Graphics.Gloss.Geometry.Line
|
||||
--import Graphics.Gloss.Geometry.Angle
|
||||
--import Graphics.Gloss.Data.Vector
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.List
|
||||
import Data.Function
|
||||
@@ -84,40 +90,6 @@ existingWallChanges poly (wall,ps) = catMaybes [w1,w2]
|
||||
else Just $ wall {_wlLine = [ c2, wp2 ] }
|
||||
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
-- 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 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}
|
||||
|
||||
|
||||
drawCutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
drawCutWalls (q:qs) walls = foldr drawCutWall walls (zip (q:qs) (qs++[q]))
|
||||
-- where (q:qs) = reverse $ orderPolygon
|
||||
-- -- $ intersectPolygonWalls ps walls
|
||||
-- $ maybeToList $ intersectSegSeg (20,0) (100,900) (-200,400) (200,400)
|
||||
-- -- $ (++) ps $ nub $ concat $ IM.elems $ fmap snd $ collidePolygonWalls ps walls
|
||||
|
||||
-- I have no idea why collidePolygonWalls is sometimes dropping an intersection
|
||||
-- point between the walls and the polygon
|
||||
@@ -144,90 +116,7 @@ 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
|
||||
|
||||
-- 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
|
||||
cutWalls1 :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
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 . 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')
|
||||
|
||||
|
||||
cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
|
||||
cutWalls qs walls = -- IM.filter (not . wallIsZeroLength) $ fuseWalls $
|
||||
drawCutWalls rs $ IM.filter (not.wallIsZeroLength)
|
||||
$ removeWallsInPolygon ps -- cwals
|
||||
(fuseWallsWith zs cwals)
|
||||
where (zs,cwals) = cutWallsProcess ps walls
|
||||
ps = orderPolygon qs
|
||||
--ps = orderPolygon $ map perturbToWallPoints qs
|
||||
rs = orderPolygon $ nub $ zs ++ qs
|
||||
-- perturbToWallPoints p = fromMaybe p $ find (\p1 -> dist p p1 < 1) wps
|
||||
|
||||
|
||||
fusePoint :: [Point2] -> Point2 -> Maybe Point2
|
||||
fusePoint ps p = find (\q -> dist p q < 5) ps
|
||||
|
||||
pointIfNotClose :: [Point2] -> Point2 -> Maybe Point2
|
||||
pointIfNotClose ps p = case fusePoint ps p of
|
||||
Nothing -> Just p
|
||||
_ -> Nothing
|
||||
|
||||
fuseWall :: ([Point2], Wall) -> ([Point2], Wall)
|
||||
fuseWall (ps, w) = (qs, w {_wlLine = newLine})
|
||||
where wp0 = _wlLine w !! 0
|
||||
wp0' = fromMaybe wp0 $ fusePoint ps wp0
|
||||
ps0 = maybeToList (pointIfNotClose ps wp0) ++ ps
|
||||
wp1 = _wlLine w !! 1
|
||||
wp1' = fromMaybe wp1 $ fusePoint ps0 wp1
|
||||
newLine = [wp0',wp1']
|
||||
qs = catMaybes [pointIfNotClose ps wp0, pointIfNotClose ps0 wp1] ++ ps
|
||||
|
||||
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)
|
||||
in (qs, IM.insert (_wlID w') w' ws)
|
||||
|
||||
wallIsZeroLength w = l !! 0 == l !! 1
|
||||
where l = _wlLine w
|
||||
|
||||
treeTrunk :: [a] -> Tree a -> Tree a
|
||||
treeTrunk [] t = t
|
||||
|
||||
Reference in New Issue
Block a user