diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs index dcb67b948..fb48bad5d 100644 --- a/src/Dodge/Block.hs +++ b/src/Dodge/Block.hs @@ -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) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 7551056bb..17bf245ce 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -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] diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 090b731d8..f5236b697 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -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'] diff --git a/src/Dodge/Weapons.hs b/src/Dodge/Weapons.hs index 1b1dafcf4..af69b9197 100644 --- a/src/Dodge/Weapons.hs +++ b/src/Dodge/Weapons.hs @@ -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 $