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

Add IntMapHelper, locate wall cutting bug

Browse Source
This commit is contained in:
jgk
2021-05-22 15:14:21 +02:00
parent 26f0ca4ab5
commit 9c2bcbec10
35 changed files with 221 additions and 139 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/LevelGen/AutoDoor.hs
+2 -2
View File
@@ -12,10 +12,10 @@ import Dodge.Creature.Property
import Geometry
import Picture
import qualified DoubleStack as DS
import qualified IntMapHelp as IM
--import Data.List
--import Data.Maybe
import qualified Data.IntMap.Strict as IM
import Control.Lens
--import Control.DeepSeq (deepseq)
@@ -33,7 +33,7 @@ autoDoorAt
-> IM.IntMap Wall
autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
where
i = newKey wls
i = IM.newKey wls
is = [i..]
mkAutoDoor
src/Dodge/LevelGen/Block.hs
+2 -2
View File
@@ -7,13 +7,13 @@ import Dodge.WorldEvent.Sound
import Dodge.LevelGen.Pathing
import Geometry
import Picture.Data
import qualified IntMapHelp as IM
import Control.Lens
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.Function
import qualified Data.IntMap.Strict as IM
import System.Random
updateBlocks :: World -> World
@@ -103,7 +103,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w
& walls %~ IM.union panes
where
lns = zip (p:ps) (ps ++ [p])
i = newKey $ _walls w
i = IM.newKey $ _walls w
is = [i.. i + length lns-1]
panes = IM.fromList $ zip is $ zipWith
(\j (a,b) -> Block
src/Dodge/LevelGen/LineBlock.hs
+2 -2
View File
@@ -8,9 +8,9 @@ import Dodge.Base
import Dodge.LevelGen.Pathing
--import Picture
import Geometry
import qualified IntMapHelp as IM
import Control.Lens
import qualified Data.IntMap as IM
putLineBlock
:: Wall -- ^ Base pane
@@ -37,7 +37,7 @@ putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr i
]
cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
linesAt p = makeLoopPairs $ cornersAt p
k = newKey $ _walls w
k = IM.newKey $ _walls w
ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
visibilityAt i
| i == 0 = [ True,True,False,True]
src/Dodge/LevelGen/StaticWalls.hs
+48 -16
View File
@@ -38,24 +38,29 @@ removeInverseWalls ((a,b):ps)
removeInverseWalls ps = ps
-- | Cut out a polygon from a set of walls, and check for errors in the
-- created walls.
-- If created walls are not consistent, rotate and expand poly and retry.
-- If created walls are not consistent, retry, rotating and expanding poly.
cutWalls :: [Point2] -> [WallP] -> [WallP]
cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
[] -> newWalls
-- _ -> cutWalls (expandPolyBy 100 ps) wls
-- _ -> cutWalls (expandPolyBy 0.01 ps) wls
_ -> cutWalls (map (rotateV 0.001) $ expandPolyBy 0.01 ps) wls
_ -> cutWallsRetry 0 ps wls
-- _ -> wls
-- _ -> error $ show ps
where
newWalls = cutWalls' ps wls
-- | As 'cutWalls', but rotate in the other direction.
cutWallsL :: [Point2] -> [WallP] -> [WallP]
cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
newWalls = cutPoly ps wls
cutWallsRetry :: Int -> [Point2] -> [WallP] -> [WallP]
--cutWallsRetry 200 ps wls = error $ show ps ++ show wls
cutWallsRetry i ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
[] -> newWalls
-- _ -> cutWalls (expandPolyBy 100 ps) wls
-- _ -> cutWalls (expandPolyBy 0.01 ps) wls
_ -> cutWalls (map (rotateV (-0.001)) $ expandPolyBy 0.01 ps) wls
_ -> cutWallsRetry (i+1) ps wls
-- _ -> wls
-- _ -> error $ show ps
where
newWalls = cutWalls' ps wls
newWalls = cutPoly ps' wls
--ps' = map (rotateV a) $ expandPolyBy 0.1 ps
ps' = map (rotateV a) $ expandPolyBy x ps
x = fromIntegral i / 100
a | even i = 0.001
| otherwise = negate 0.001
-- | Cut out a polygon from a set of walls, and check for errors in the
-- created walls.
-- Give error if created walls are not consistent.
@@ -72,7 +77,7 @@ cutWalls'' ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
++ "\nWalls after cut:\n"
++ unlines (map show newWalls)
where
newWalls = cutWalls' ps wls
newWalls = cutPoly ps wls
errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
-- | Given a specific wall and list of walls, checks that the number of walls leaving the
-- second point is the same as the number of walls entering the second point of
@@ -109,10 +114,10 @@ checkWallLeft (x,y) wls
-- 5. remove any walls that ended up zero length after fusing
-- 6. remove any duplicate walls
-- Unclear behaviour if a line in the polygon is colinear with a wall.
cutWalls' :: [Point2] -> [WallP] -> [WallP]
cutWalls' qs wls =
cutPoly :: [Point2] -> [WallP] -> [WallP]
cutPoly qs wls =
nub
. filter (not.wallIsZeroLength)
. filter (not . wallIsZeroLength)
. fuseWallsWith zs
. addPolyWalls rs
-- . removeWallsInPolygon ps
@@ -131,6 +136,7 @@ expandPolyBy x ps = map f ps
where
cp = 1/fromIntegral (length ps) *.* foldr (+.+) (0,0) ps
f p = p +.+ x *.* (p -.- cp)
--f p = p +.+ x *.* normalizeV (p -.- cp)
-- | Given a polygon expressed as a list of points and a collection of walls,
-- returns:
-- fst: points of the polygon's intersection with walls
@@ -223,3 +229,29 @@ removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
removeWallsInPolygon ps = filter (not . cond)
where
cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
brokenWalls :: [(Point2,Point2)]
brokenWalls =
[((330.12192,3032.2456),(190.52365,2995.8352)),((190.52365,2995.8352),(203.94716,2945.9377)),((214.33855,2907.311),(230.12193,2859.0405)),((230.12193,2859.0405),(366.7245,2895.643)),((366.7245,2895.643),(330.12192,3032.2456)),((366.7245,2895.643),(230.12193,2859.0405)),((230.12193,2859.0405),(266.7245,2722.438)),((266.7245,2722.438),(403.32703,2759.0405)),((403.32703,2759.0405),(503.32703,2932.2456)),((466.72446,3068.8481),(330.12192,3032.2456)),((330.12192,3032.2456),(366.7245,2895.643)),((503.32703,2932.2456),(466.72446,3068.8481)),((203.94716,2945.9377),(145.99155,2930.4084)),((156.38292,2891.7817),(214.33855,2907.311)),((107.47222,2920.979),(34.06077,2901.2295)),((34.06077,2901.2295),(52.571453,2832.4224)),((70.17772,2796.55),(174.45558,2824.6025)),((174.45558,2824.6025),(156.38292,2891.7817)),((100.76944,2955.4202),(107.47222,2920.979)),((145.99155,2930.4084),(140.79587,2949.722)),((52.571453,2832.4224),(35.882084,2827.9504)),((31.745949,2785.4312),(70.17772,2796.55)),((88.14497,3002.5354),(100.76944,2955.4202)),((140.79587,2949.722),(120.21855,3027.0303)),((35.882084,2827.9504),(-22.07344,2812.4214)),((-31.039248,2768.608),(31.745949,2785.4312)),((-261.32483,3408.5737),(-303.9881,3451.237)),((-303.9881,3451.237),(-332.27234,3422.9526)),((-332.27234,3422.9526),(-289.84595,3380.5264)),((-261.56174,3352.242),(88.14497,3002.5354)),((120.21855,3027.0303),(-233.27742,3380.5264)),((-289.84595,3380.5264),(-332.2724,3338.0999)),((-332.2724,3338.0999),(-303.9881,3309.8157)),((-303.9881,3309.8157),(-261.56174,3352.242)),((-22.07344,2812.4214),(-89.68823,2794.304)),((-79.335526,2755.667),(-31.039248,2768.608)),((-210.16953,3456.4133),(-261.32483,3408.5737)),((-233.27742,3380.5264),(-194.64026,3419.1633)),((-128.32533,2783.9514),(-200.79468,3054.4106)),((-200.79468,3054.4106),(-780.35016,2899.1191)),((-780.35016,2899.1191),(-625.05865,2319.5635)),((-625.05865,2319.5635),(-45.503174,2474.855)),((-45.503174,2474.855),(-117.97253,2745.3142)),((-89.68823,2794.304),(-128.32533,2783.9514)),((-117.97253,2745.3142),(-79.335526,2755.667)),((-178.49438,3590.2566),(-241.50847,3573.372)),((-241.50847,3573.372),(-210.16953,3456.4133)),((-194.64026,3419.1633),(-136.80266,3434.6611)),((-98.165634,3445.014),(-139.85736,3600.6094)),((-92.98925,3425.6953),(-98.165634,3445.014)),((-136.80266,3434.6611),(-127.74397,3400.8535)),((-187.553,3624.064),(-178.49438,3590.2566)),((-139.85736,3600.6094),(-148.91603,3634.4167)),((-127.74397,3400.8535),(-111.20285,3339.121)),((-78.55679,3371.8325),(-92.98925,3425.6953)),((-349.5008,4383.0093),(-388.13782,4372.6563)),((-388.13782,4372.6563),(-485.18823,3653.0168)),((-485.18823,3653.0168),(-477.42368,3624.039)),((-477.42368,3624.039),(-206.96445,3696.5085)),((-168.32744,3706.861),(102.131805,3779.3306)),((102.131805,3779.3306),(94.36725,3808.308)),((94.36725,3808.308),(-349.5008,4383.0093)),((-206.96445,3696.5085),(-187.553,3624.064)),((-148.91603,3634.4167),(-168.32744,3706.861)),((299.35522,3346.2668),(97.2383,3547.9797)),((97.2383,3547.9797),(-78.55679,3371.8325)),((-111.20285,3339.121),(116.74672,3110.6904)),((116.74672,3110.6904),(320.08704,3314.438)),((352.084,3395.578),(299.35522,3346.2668)),((320.08704,3314.438),(367.6133,3358.328)),((495.06226,3666.979),(293.8115,3613.054)),((293.8115,3613.054),(352.084,3395.578)),((367.6133,3358.328),(563.6875,3410.866)),((563.6875,3410.866),(495.06226,3666.979))]
intersectingBrokenWalls :: [(Point2,Point2)]
intersectingBrokenWalls = filter (\(a,b) -> test a b) brokenWalls
where
polyPairs = zip brokenPoly (tail brokenPoly ++ [head brokenPoly])
test a b = any (isJust . uncurry (myIntersectSegSeg a b)) polyPairs
brokenPoly :: [Point2]
brokenPoly = [(434.66675,2833.3225),(503.9488,2793.3225),(523.9488,2827.9636),(454.66675,2867.9636)]
iBWall :: (Point2,Point2)
iBWall = ((403.32703,2759.0405),(503.32703,2932.2456))
expandToSquare :: (Point2,Point2) -> [(Point2,Point2)]
expandToSquare (a,b) = [(a,b),(b,c),(c,d),(d,a)]
where
v = a -.- b
c = b +.+ vNormal v
d = a +.+ vNormal v
minWalls :: [(Point2,Point2)]
minWalls = expandToSquare iBWall
src/Dodge/LevelGen/SwarmPlacement.hs
+3 -4
View File
@@ -3,14 +3,13 @@ module Dodge.LevelGen.SwarmPlacement
)
where
import Dodge.Data
import Dodge.Base
import Dodge.LevelGen.Data
import Dodge.Creature.State.Data
import Geometry
import qualified IntMapHelp as IM
import Data.List
import qualified Data.IntSet as IS
import qualified Data.IntMap as IM
import Control.Lens
swarmPS :: Int -> Point2 -> Float -> Creature -> Placement
@@ -26,7 +25,7 @@ setSwarm w ps = updateCrs w' & creatureGroups %~ IM.insert gid theGroupParams
(w', crs) = mapAccumR updateCrit w ps
is = IS.fromList $ map _crID crs
cpos = centroid $ map _crPos crs
gid = newKey (_creatureGroups w')
gid = IM.newKey (_creatureGroups w')
theGroupParams = CrGroupParams
{ _crGroupParamID = gid
, _crGroupIDs = is
@@ -52,5 +51,5 @@ updateCrit w pl = (w & creatures %~ IM.insert cid cr
p = _psPos $ _placementSpot pl
rot = _psRot $ _placementSpot pl
scr = _unPutCrit $ _psType $ _placementSpot pl
cid = newKey (_creatures w)
cid = IM.newKey (_creatures w)
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
src/Dodge/LevelGen/TriggerDoor.hs
+5 -5
View File
@@ -9,10 +9,10 @@ import Dodge.LevelGen.Pathing
import Picture
import Geometry
import qualified DoubleStack as DS
import qualified IntMapHelp as IM
import Data.List
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Data.Graph.Inductive hiding ((&))
@@ -24,7 +24,7 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ set pathGraph' newGraphPairs
$ putDoubleDoor c cond a b w
where
bid = newKey $ _buttons w
bid = IM.newKey $ _buttons w
cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
@@ -42,7 +42,7 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ set pathGraph' newGraphPairs
$ putDoubleDoor c cond a b w
where
bid = newKey $ _buttons w
bid = IM.newKey $ _buttons w
cond w' = BtOn == _btState (_buttons w' IM.! bid)
bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
@@ -67,14 +67,14 @@ putDoor c cond pss = over walls triggerDoor
where
triggerDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond pss is
where
is = [newKey wls..]
is = [IM.newKey wls..]
putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
putDoubleDoor c cond a b = over walls triggerDoubleDoor
where
triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoubleDoor c cond a b is
where
is = [newKey wls..]
is = [IM.newKey wls..]
mkTriggerDoor
:: Color