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

Mid strictifying

Browse Source
This commit is contained in:
jgk
2021-07-29 23:42:27 +02:00
parent 67aa5c05c7
commit bd8ef3f416
22 changed files with 359 additions and 325 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/LevelGen/StaticWalls.hs
+73 -71
View File
@@ -6,11 +6,13 @@ module Dodge.LevelGen.StaticWalls
where
import Dodge.Data
import Geometry
import Geometry.Data
import FoldableHelp
--import Control.Lens
import Data.List
import Data.Maybe
import Data.Bifunctor
-- | Describe a wall as two points.
-- Order is important: the wall face is to the left of the line going from
-- 'fst' to 'snd'.
@@ -136,7 +138,7 @@ cutPoly qs wls =
expandPolyBy :: Float -> [Point2] -> [Point2]
expandPolyBy x ps = map f ps
where
cp = 1/fromIntegral (length ps) *.* foldr (+.+) (0,0) ps
cp = 1/fromIntegral (length ps) *.* foldr (+.+) (V2 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,
@@ -231,20 +233,20 @@ findWallsInPolygon ps = filter cond
cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
brokenWalls :: [(Point2,Point2)]
brokenWalls =
brokenWalls = map (first toV2 . second toV2)
[((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 (uncurry test) brokenWalls
where
polyPairs = zip brokenPoly (tail brokenPoly ++ [head brokenPoly])
test a b = any (isJust . uncurry (myIntersectSegSeg a b)) polyPairs
--intersectingBrokenWalls :: [(Point2,Point2)]
--intersectingBrokenWalls = filter (uncurry test) 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)]
--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))
--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)]
@@ -253,65 +255,65 @@ expandToSquare (a,b) = [(a,b),(b,c),(c,d),(d,a)]
c = b +.+ vNormal v
d = a +.+ vNormal v
minWalls :: [(Point2,Point2)]
minWalls = expandToSquare iBWall
--minWalls :: [(Point2,Point2)]
--minWalls = expandToSquare iBWall
brokenZs :: [Point2]
brokenCwals :: [WallP]
(brokenZs,brokenCwals) = cutWallsWithPoints brokenPoly brokenWalls
--brokenZs :: [Point2]
--brokenCwals :: [WallP]
--(brokenZs,brokenCwals) = cutWallsWithPoints brokenPoly brokenWalls
minZs :: [Point2]
minCwals :: [WallP]
(minZs,minCwals) = cutWallsWithPoints brokenPoly minWalls
brokenRs :: [Point2]
brokenRs = orderPolygon $ nub $ minZs ++ brokenPoly
brokenAfterRemovedWalls :: [WallP]
brokenAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) brokenCwals
minAfterRemovedWalls :: [WallP]
minAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) minCwals
brokenRemovedWalls :: [WallP]
brokenRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) brokenCwals
minRemovedWalls :: [WallP]
minRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) minCwals
addedPolyWalls :: [Point2] -> [WallP] -> [WallP]
addedPolyWalls ps wls = addPolyWalls ps wls \\ wls
brokenAddedWalls :: [WallP]
brokenAddedWalls = addedPolyWalls brokenRs brokenAfterRemovedWalls
minAddedWalls :: [WallP]
minAddedWalls = addedPolyWalls brokenRs minAfterRemovedWalls
brokenAdd :: WallP
brokenAdd = head brokenAddedWalls
findShadowWall :: WallP -> [WallP] -> Maybe WallP
findShadowWall (p1,p2) wls = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
where
p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* rotateV (negate $ pi/4) (vNormal (p2 -.- p1))
f = uncurry $ myIntersectSegSeg p3 p4
findShadowWalls :: WallP -> [WallP] -> [WallP]
findShadowWalls (p1,p2) wls = hitWls
where
hitWls = sortOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
f = uncurry $ myIntersectSegSeg p3 p4
addWallDebug :: WallP -> [WallP] -> [WallP]
addWallDebug (p1,p2) wls =
case maybeWs of
Just ws -> if uncurry isLHS ws p3
then wls
else (p1,p2) : wls
Nothing -> (p1,p2) : wls
where
maybeWs = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
f = uncurry $ myIntersectSegSeg p3 p4
--minZs :: [Point2]
--minCwals :: [WallP]
--(minZs,minCwals) = cutWallsWithPoints brokenPoly minWalls
--
--brokenRs :: [Point2]
--brokenRs = orderPolygon $ nub $ minZs ++ brokenPoly
--
--brokenAfterRemovedWalls :: [WallP]
--brokenAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) brokenCwals
--minAfterRemovedWalls :: [WallP]
--minAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) minCwals
--
--brokenRemovedWalls :: [WallP]
--brokenRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) brokenCwals
--minRemovedWalls :: [WallP]
--minRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) minCwals
--
--addedPolyWalls :: [Point2] -> [WallP] -> [WallP]
--addedPolyWalls ps wls = addPolyWalls ps wls \\ wls
--
--brokenAddedWalls :: [WallP]
--brokenAddedWalls = addedPolyWalls brokenRs brokenAfterRemovedWalls
--minAddedWalls :: [WallP]
--minAddedWalls = addedPolyWalls brokenRs minAfterRemovedWalls
--
--brokenAdd :: WallP
--brokenAdd = head brokenAddedWalls
--
--findShadowWall :: WallP -> [WallP] -> Maybe WallP
--findShadowWall (p1,p2) wls = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
-- where
-- p3 = 0.5 *.* (p1 +.+ p2)
-- p4 = p3 +.+ 10000 *.* rotateV (negate $ pi/4) (vNormal (p2 -.- p1))
-- f = uncurry $ myIntersectSegSeg p3 p4
--
--findShadowWalls :: WallP -> [WallP] -> [WallP]
--findShadowWalls (p1,p2) wls = hitWls
-- where
-- hitWls = sortOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
-- p3 = 0.5 *.* (p1 +.+ p2)
-- p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
-- f = uncurry $ myIntersectSegSeg p3 p4
--
--addWallDebug :: WallP -> [WallP] -> [WallP]
--addWallDebug (p1,p2) wls =
-- case maybeWs of
-- Just ws -> if uncurry isLHS ws p3
-- then wls
-- else (p1,p2) : wls
-- Nothing -> (p1,p2) : wls
-- where
-- maybeWs = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
-- p3 = 0.5 *.* (p1 +.+ p2)
-- p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
-- f = uncurry $ myIntersectSegSeg p3 p4
src/Dodge/LevelGen/Switch.hs
+5 -4
View File
@@ -5,6 +5,7 @@ import Dodge.SoundLogic
import Dodge.Picture.Layer
import Picture
import Geometry
import Geometry.Data
import qualified Data.IntMap.Strict as IM
import Control.Lens
@@ -14,7 +15,7 @@ makeButton
-> Button
makeButton c eff = Button
{ _btPict = setLayer 0 . onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
, _btPos = (0,0)
, _btPos = (V2 0 0)
, _btRot = 0
, _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
-- . set (buttons . ix (_btID b) . btPict)
@@ -38,7 +39,7 @@ makeSwitch
-> Button
makeSwitch c effOn effOff = Button
{ _btPict = offPict
, _btPos = (0,0)
, _btPos = (V2 0 0)
, _btRot = 0
, _btEvent = flipSwitch
, _btID = 0
@@ -53,11 +54,11 @@ makeSwitch c effOn effOff = Button
_ -> error "Trying to switch a button with no label"
offPict = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) 10
,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
,polygon $ map toV2 [(-2,-5),(-10,4),(-6,4),(2,-5)]
]
onPict = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) 10
,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
,polygon $ map toV2 [(-2,-5), (6,4),( 10,4),(2,-5)]
]
turnOn :: Button -> Button
turnOn bt = bt