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:
jgk
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
Nothing -> False
killBlock :: Wall -> World -> World
killBlock bl w = f bl .
flip (foldr unshadow)
src/Dodge/Data.hs
+56 -54
View File
@@ -529,60 +529,62 @@ data Smoke =
data WLID = WLID { _wlIDx :: Int, _wlIDy :: Int, _wlIDid :: Int}
data Wall = Wall
{ _wlLine :: [Point2] , _wlID :: Int
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
-- , _wlID' :: WLID
}
| BlockAutoDoor
{ _wlLine :: [Point2]
, _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _blIDs :: [Int]
, _blHP :: Int
, _wlIsSeeThrough :: Bool
-- , _wlID' :: WLID
}
| AutoDoor
{ _wlLine :: [Point2] , _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
-- , _wlID' :: WLID
-- , _doorLine :: [Point2]
}
| Door
{ _wlLine :: [Point2] , _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
-- , _wlID' :: WLID
-- , _doorLine :: [Point2]
}
| Block
{ _wlLine :: [Point2]
, _wlID :: Int
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _blIDs :: [Int]
, _blHP :: Int
, _wlIsSeeThrough :: Bool
, _blVisible :: Bool
, _blShadows :: [Int]
, _blDegrades :: [Int]
-- , _wlID' :: WLID
}
data Wall
= Wall
{ _wlLine :: [Point2] , _wlID :: Int
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
}
| BlockAutoDoor
{ _wlLine :: [Point2]
, _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _blIDs :: [Int]
, _blHP :: Int
, _wlIsSeeThrough :: Bool
}
| AutoDoor
{ _wlLine :: [Point2] , _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
}
| Door
{ _wlLine :: [Point2] , _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
}
| Block
{ _wlLine :: [Point2]
, _wlID :: Int
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _blIDs :: [Int]
, _blHP :: Int
, _wlIsSeeThrough :: Bool
, _blVisible :: Bool
, _blShadows :: [Int]
, _blDegrades :: [Int]
}
| MultiBlock
{ _wlLine :: [Point2]
, _wlID :: Int
, _wlColor :: Color
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
, _subWalls :: [Wall]
}
data Block' = Block'
{ _blPoly :: [Point2]
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']
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 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
,_ptUpdate' = ptTimer' 0
}
)
where sp = pos
xp = sp +.+ 800 *.* unitVectorAtAngle dir
--thHit = listToMaybe $ filter notSeeThrough $ thingsHitExceptCrLongLine mcid sp xp w
where xp = pos +.+ 800 *.* unitVectorAtAngle dir
(a,g) = randomR (-0.7,0.7) $ _randGen w
reflectDir wall = a + (argV $ reflectIn
(_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
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
flarePos p = p +.+ ((a + 0.8) * 3) *.* (normalizeV (sp -.- p))
-- 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
-- flarePos p = p +.+ ((a + 0.8) * 3) *.* (normalizeV (pos -.- p))
f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either3 Creature Wall ForceField),[Point2])
f seenWs x y = case listToMaybe $ filter (h' seenWs)
$ 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' _ _ = True
(thHit, ps) = f [] sp xp
hitSpecific
(thHit, ps) = f [] pos xp
hitEffect
= case thHit of
Just (p,E3x1 cr)
-> over (creatures . ix (_crID cr) . crState . crDamage) ((:) $ Lasering 3 sp p xp)
. over worldEvents ((.) $ flareAt yellow (flarePos p))
Just (p,E3x2 wl) -> createSpark 8 colID (p +.+ safeNormalizeV (sp -.- p))
-> over (creatures . ix (_crID cr) . crState . crDamage) ((:) $ Lasering 3 pos p xp)
-- . over worldEvents ((.) $ flareAt yellow (flarePos p))
Just (p,E3x2 wl) -> createSpark 8 colID (p +.+ safeNormalizeV (pos -.- p))
(reflectDir wl) Nothing
_ -> id
pic = pictures [ fadeLine sp (head ps) 0.2 40 yellow
, setLayer 1 $ color (withAlpha 0.9 white) $ vThickLine (sp:ps)
, setLayer 1 $ color (withAlpha 0.5 yellow) $ vvThickLine (sp:ps)
pic = pictures [ fadeLine pos (head ps) 0.2 40 yellow
, setLayer 1 $ color (withAlpha 0.9 white) $ vThickLine (pos: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 sp ep alph width col = setLayer 1 $