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/Block.hs
-1
View File
@@ -30,7 +30,6 @@ updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) d
blockIsDead wl = case wl ^? blHP of Just x -> x <= 0 blockIsDead wl = case wl ^? blHP of Just x -> x <= 0
Nothing -> False Nothing -> False
killBlock :: Wall -> World -> World killBlock :: Wall -> World -> World
killBlock bl w = f bl . killBlock bl w = f bl .
flip (foldr unshadow) flip (foldr unshadow)
src/Dodge/Data.hs
+10 -8
View File
@@ -529,13 +529,13 @@ data Smoke =
data WLID = WLID { _wlIDx :: Int, _wlIDy :: Int, _wlIDid :: Int} data WLID = WLID { _wlIDx :: Int, _wlIDy :: Int, _wlIDid :: Int}
data Wall = Wall data Wall
= Wall
{ _wlLine :: [Point2] , _wlID :: Int { _wlLine :: [Point2] , _wlID :: Int
, _wlColor :: Color , _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing) , _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool , _wlSeen :: Bool
, _wlIsSeeThrough :: Bool , _wlIsSeeThrough :: Bool
-- , _wlID' :: WLID
} }
| BlockAutoDoor | BlockAutoDoor
{ _wlLine :: [Point2] { _wlLine :: [Point2]
@@ -547,7 +547,6 @@ data Wall = Wall
, _blIDs :: [Int] , _blIDs :: [Int]
, _blHP :: Int , _blHP :: Int
, _wlIsSeeThrough :: Bool , _wlIsSeeThrough :: Bool
-- , _wlID' :: WLID
} }
| AutoDoor | AutoDoor
{ _wlLine :: [Point2] , _wlID :: Int { _wlLine :: [Point2] , _wlID :: Int
@@ -556,8 +555,6 @@ data Wall = Wall
, _wlDraw :: Maybe (Wall -> Drawing) , _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool , _wlSeen :: Bool
, _wlIsSeeThrough :: Bool , _wlIsSeeThrough :: Bool
-- , _wlID' :: WLID
-- , _doorLine :: [Point2]
} }
| Door | Door
{ _wlLine :: [Point2] , _wlID :: Int { _wlLine :: [Point2] , _wlID :: Int
@@ -566,8 +563,6 @@ data Wall = Wall
, _wlDraw :: Maybe (Wall -> Drawing) , _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool , _wlSeen :: Bool
, _wlIsSeeThrough :: Bool , _wlIsSeeThrough :: Bool
-- , _wlID' :: WLID
-- , _doorLine :: [Point2]
} }
| Block | Block
{ _wlLine :: [Point2] { _wlLine :: [Point2]
@@ -581,7 +576,14 @@ data Wall = Wall
, _blVisible :: Bool , _blVisible :: Bool
, _blShadows :: [Int] , _blShadows :: [Int]
, _blDegrades :: [Int] , _blDegrades :: [Int]
-- , _wlID' :: WLID }
| MultiBlock
{ _wlLine :: [Point2]
, _wlID :: Int
, _wlColor :: Color
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
, _subWalls :: [Wall]
} }
data Block' = Block' data Block' = Block'
src/Dodge/LevelGen.hs
+28 -32
View File
@@ -31,19 +31,10 @@ import Data.Graph.Inductive.NodeMap
import Data.Tree 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 :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
collidePointAllWalls p1 p2 walls = IM.filter f walls collidePointAllWalls p1 p2 walls = IM.filter f walls
where f wall where f wall
@@ -52,7 +43,6 @@ collidePointAllWalls p1 p2 walls = IM.filter f walls
_ -> True _ -> True
-- returns walls that collide with lines, and the point of collision -- returns walls that collide with lines, and the point of collision
collidePointAllWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,Point2) collidePointAllWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,Point2)
collidePointAllWallsPoints p1 p2 walls = IM.mapMaybe f walls collidePointAllWallsPoints p1 p2 walls = IM.mapMaybe f walls
where f wall 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))) s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs)))
-.- p -.- p
-- ok, now to find out which new walls need to be drawn -- ok, now to find out which new walls need to be drawn
drawCutWall :: (Point2, Point2) -> IM.IntMap Wall -> IM.IntMap Wall drawCutWall :: (Point2, Point2) -> IM.IntMap Wall -> IM.IntMap Wall
drawCutWall (p1,p2) walls = 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 then walls
else IM.insert k newWall walls else IM.insert k newWall walls
Nothing -> IM.insert k newWall walls Nothing -> IM.insert k newWall walls
where p3 = 0.5 *.* (p1 +.+ p2) where p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1) p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
maybeW = wallOnLine p3 p4 walls maybeW = wallOnLine p3 p4 walls
k = case IM.lookupMax walls k = newKey walls
of Nothing -> 0
Just (j,_) -> j + 1
newWall = basicWall {_wlLine = [p1,p2], _wlID = k} 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 -- new procedure: line by line
-- then remove all walls inside the polygon -- then remove all walls inside the polygon
-- abuses the list nature of wlLine -- given a segment and a wall, adds a cut point to the wall if it intersects the
cutWall1 :: Point2 -> Point2 -> Wall -> Wall -- segment
cutWall1 p1 p2 wall = case maybeCP of cutWall :: Point2 -> Point2 -> Wall -> Wall
cutWall p1 p2 wall = case maybeCP of
Nothing -> wall Nothing -> wall
Just cp -> wall {_wlLine = [cp,w0,w1]} Just cp -> wall {_wlLine = [cp,w0,w1]}
where wl = _wlLine wall where wl = _wlLine wall
w0 = wl !! 0 w0 = wl !! 0
w1 = wl !! 1 w1 = wl !! 1
w0' = w0 +.+ normalizeV (w0 -.- w1) maybeCP = intersectExtendedSegSeg p1 p2 w0 w1
w1' = w1 +.+ normalizeV (w1 -.- w0) -- intersects two segments, each extended by one unit in both directions
p1' = p1 +.+ normalizeV (p1 -.- p2) intersectExtendedSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2'
where p1' = p1 +.+ normalizeV (p1 -.- p2)
p2' = p2 +.+ normalizeV (p2 -.- p1) p2' = p2 +.+ normalizeV (p2 -.- p1)
pT = p1' +.+ vNormal (normalizeV (p1 -.- p2)) a1' = a1 +.+ normalizeV (a1 -.- a2)
pB = p1' -.- vNormal (normalizeV (p1 -.- p2)) a2' = a2 +.+ normalizeV (a2 -.- a1)
--maybeCP = intersectSegSeg p1' p2' w0' w1'-- <|> intersectSegSeg w0 w1 pT pB
--maybeCP = inSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB -- given a segment and a collection of walls, cuts each wall where it intersects
maybeCP = inSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB -- with the segment, adds the two cut walls
--maybeCP = intersectSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB
cutWalls1 :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall cutWalls1 :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
cutWalls1 p1 p2 ws = foldr splitAndAdd ws $ IM.map (cutWall1 p1 p2) ws cutWalls1 p1 p2 ws = foldr addTwoWallsIfCut ws $ IM.map (cutWall p1 p2) ws
where splitAndAdd w ws where addTwoWallsIfCut w ws
= case _wlLine w of = case _wlLine w of
(cp:w0:w1:[]) -> IM.insert (newKey ws) (w {_wlLine = [cp,w1] (cp:w0:w1:[]) -> IM.insert (newKey ws) (w {_wlLine = [cp,w1]
,_wlID = newKey ws}) ,_wlID = newKey ws})
$ IM.insert (_wlID w) (w {_wlLine = [w0,cp]}) ws $ IM.insert (_wlID w) (w {_wlLine = [w0,cp]}) ws
(x:y:[]) -> ws (x:y:[]) -> ws
-- lists the points of intersection between a segment and collection of walls
cutWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> [Point2] cutWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> [Point2]
cutWallsPoints p1 p2 ws = map head $ filter (\xs -> length xs > 2) 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 :: [Point2] -> IM.IntMap Wall -> ([Point2], IM.IntMap Wall)
cutWallsProcess (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p])) 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 :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
cutWalls qs walls = -- IM.filter (not . wallIsZeroLength) $ fuseWalls $ 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 fuseWalls ws = snd $ IM.foldr fuseWalls' ([], IM.empty) ws
where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w) where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w)
in (qs, IM.insert (_wlID w') w' ws) in (qs, IM.insert (_wlID w') w' ws)
fuseWallsWith :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall fuseWallsWith :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
fuseWallsWith zs ws = snd $ IM.foldr fuseWalls' (zs, IM.empty) ws fuseWallsWith zs ws = snd $ IM.foldr fuseWalls' (zs, IM.empty) ws
where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w) 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 , _wlID = n
, _doorMech = dm , _doorMech = dm
, _wlColor = dim $ yellow , _wlColor = dim $ yellow
, _wlDraw = Just drawAutoDoor -- , _wlDraw = Just drawAutoDoor
, _wlDraw = Nothing
, _wlSeen = False , _wlSeen = False
, _wlIsSeeThrough = False , _wlIsSeeThrough = False
-- , _doorLine = [a,b,a',b'] -- , _doorLine = [a,b,a',b']
src/Dodge/Weapons.hs
+16 -35
View File
@@ -1598,25 +1598,23 @@ makeLaserAt phaseV pos dir mcid = Particle'
moveLaser :: Float -> Point2 -> Float -> Maybe Int -> World -> Particle' -> (World, Maybe Particle') moveLaser :: Float -> Point2 -> Float -> Maybe Int -> World -> Particle' -> (World, Maybe Particle')
moveLaser phaseV pos dir mcid w pt moveLaser phaseV pos dir mcid w pt
= ( set randGen g $ over worldEvents ((.) flares) $ hitSpecific w = ( set randGen g
-- $ over worldEvents ((.) flares)
$ hitEffect w
, Just pt {_ptPict' = onLayer PtLayer $ pic , Just pt {_ptPict' = onLayer PtLayer $ pic
,_ptUpdate' = ptTimer' 0 ,_ptUpdate' = ptTimer' 0
} }
) )
where sp = pos where xp = pos +.+ 800 *.* unitVectorAtAngle dir
xp = sp +.+ 800 *.* unitVectorAtAngle dir
--thHit = listToMaybe $ filter notSeeThrough $ thingsHitExceptCrLongLine mcid sp xp w
(a,g) = randomR (-0.7,0.7) $ _randGen w (a,g) = randomR (-0.7,0.7) $ _randGen w
reflectDir wall = a + (argV $ reflectIn reflectDir wall = a + (argV $ reflectIn
(_wlLine wall !! 1 -.- _wlLine wall !! 0) (_wlLine wall !! 1 -.- _wlLine wall !! 0)
(xp -.- sp) (xp -.- pos)
) )
notSeeThrough (p,E3x2 wl) = not $ _wlIsSeeThrough wl
notSeeThrough _ = True
(colID,_) = randomR (0,11) $ _randGen w (colID,_) = randomR (0,11) $ _randGen w
flares w = foldr (\p w' -> flareAt' yellow 0.01 0.02 p w') w flarePs -- flares w = foldr (\p w' -> flareAt' yellow 0.01 0.02 p w') w flarePs
flarePs = zipWith (\x y -> x +.+ 5 *.* normalizeV (y -.- x)) ps $ tail ps -- flarePs = zipWith (\x y -> x +.+ 5 *.* normalizeV (y -.- x)) ps $ tail ps
flarePos p = p +.+ ((a + 0.8) * 3) *.* (normalizeV (sp -.- p)) -- flarePos p = p +.+ ((a + 0.8) * 3) *.* (normalizeV (pos -.- p))
f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either3 Creature Wall ForceField),[Point2]) f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either3 Creature Wall ForceField),[Point2])
f seenWs x y = case listToMaybe $ filter (h' seenWs) f seenWs x y = case listToMaybe $ filter (h' seenWs)
$ thingsHitExceptCrLongLine Nothing x y w of $ thingsHitExceptCrLongLine Nothing x y w of
@@ -1649,36 +1647,19 @@ moveLaser phaseV pos dir mcid w pt
h' ws (_,E3x2 wl) = not $ any (\w -> _wlID w == _wlID wl) ws h' ws (_,E3x2 wl) = not $ any (\w -> _wlID w == _wlID wl) ws
h' _ _ = True h' _ _ = True
(thHit, ps) = f [] sp xp (thHit, ps) = f [] pos xp
hitSpecific hitEffect
= case thHit of = case thHit of
Just (p,E3x1 cr) Just (p,E3x1 cr)
-> over (creatures . ix (_crID cr) . crState . crDamage) ((:) $ Lasering 3 sp p xp) -> over (creatures . ix (_crID cr) . crState . crDamage) ((:) $ Lasering 3 pos p xp)
. over worldEvents ((.) $ flareAt yellow (flarePos p)) -- . over worldEvents ((.) $ flareAt yellow (flarePos p))
Just (p,E3x2 wl) -> createSpark 8 colID (p +.+ safeNormalizeV (sp -.- p)) Just (p,E3x2 wl) -> createSpark 8 colID (p +.+ safeNormalizeV (pos -.- p))
(reflectDir wl) Nothing (reflectDir wl) Nothing
_ -> id _ -> id
pic = pictures [ fadeLine sp (head ps) 0.2 40 yellow pic = pictures [ fadeLine pos (head ps) 0.2 40 yellow
, setLayer 1 $ color (withAlpha 0.9 white) $ vThickLine (sp:ps) , setLayer 1 $ color (withAlpha 0.9 white) $ vThickLine (pos:ps)
, setLayer 1 $ color (withAlpha 0.5 yellow) $ vvThickLine (sp:ps) , setLayer 1 $ color (withAlpha 0.5 yellow) $ vvThickLine (pos:ps)
] ]
-- case thHit of
-- Nothing ->
-- pictures [color (withAlpha 0.05 yellow) $ lineOfThickness (a*20+40) (sp:ps)
-- ,color (withAlpha 0.3 yellow) $ vvThickLine (sp:ps)
-- ,color (withAlpha 0.9 white) $ vThickLine (sp:ps)
-- ,fadeLine lp op 0.9 3 white
-- ,fadeLine lp op 0.3 3 yellow
-- ,fadeLine lp op 0.05 (a*20+40) yellow
-- ]
-- _ ->
-- pictures [color (withAlpha 0.05 yellow) $ lineOfThickness (a*20+40) (sp:ps)
-- ,color (withAlpha 0.3 yellow) $ vvThickLine (sp:ps)
-- ,color (withAlpha 0.9 white) $ vThickLine (sp:ps)
-- ]
-- where lp = last ps
-- lp' = last $ init (sp:ps)
-- op = lp +.+ 50 *.* normalizeV (lp -.- lp')
fadeLine :: Point2 -> Point2 -> Float -> Float -> Color -> Picture fadeLine :: Point2 -> Point2 -> Float -> Float -> Color -> Picture
fadeLine sp ep alph width col = setLayer 1 $ fadeLine sp ep alph width col = setLayer 1 $