Cleanup particles slightly

2021-09-03 17:26:21 +01:00
parent 111b86d2df
commit fd85093833
10 changed files with 64 additions and 95 deletions
@@ -363,7 +363,7 @@ data Particle
        , _ptTimer :: Int
        , _ptColor :: Color
        }
-    | Bul'  
+    | BulletPt  
        { _ptDraw :: Particle -> Picture
        , _ptUpdate' :: World -> Particle -> (World, Maybe Particle)
        , _btVel' :: Point2
@@ -386,17 +386,6 @@ data Particle
        , _btHitEffect' :: HitEffect
        , _ptZ :: Float
        }
-    | Pt'  
-        { _ptDraw :: Particle -> Picture
-        , _ptUpdate' :: World -> Particle -> (World, Maybe Particle)
-        , _btVel' :: Point2
-        , _btColor' :: Color
-        , _btPos' :: Point2
-        , _btPassThrough' :: Maybe Int
-        , _btWidth' :: Float 
-        , _btTimer' :: Int
-        , _btHitEffect' :: HitEffect
-        }
    | Shockwave' 
        { _ptDraw       :: Particle -> Picture
        , _ptUpdate'    :: World -> Particle -> (World, Maybe Particle)
@@ -11,14 +11,14 @@ import Dodge.WorldEvent.Cloud
 import Dodge.SoundLogic
 import Dodge.SoundLogic.Synonyms
 import Geometry.Data
-import Dodge.GameRoom
-import Geometry
+--import Dodge.GameRoom
+--import Geometry

 import System.Random
 import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
-import Data.List (sortOn)
+--import Data.List (sortOn)

 firstWorld :: IO World
 firstWorld = do
@@ -53,10 +53,11 @@ initialWorld = defaultWorld
    , _worldState = M.empty
    }
 testStringInit :: World -> [String]
-testStringInit w = (show . _crPos $ _creatures w IM.! 0) 
-    : (map show . _grBound . last $ sortOn _grName grs) 
-    ++ closeRooms
-  where
-    closeRooms = map _grName $ filter (pointInOrOnPolygon p . _grBound) grs
-    grs = _gameRooms w
-    p = _cameraViewFrom w
+testStringInit _ = []
+--testStringInit w = (show . _crPos $ _creatures w IM.! 0) 
+--    : (map show . _grBound . last $ sortOn _grName grs) 
+--    ++ closeRooms
+--  where
+--    closeRooms = map _grName $ filter (pointInOrOnPolygon p . _grBound) grs
+--    grs = _gameRooms w
+--    p = _cameraViewFrom w
@@ -645,12 +645,16 @@ aTeslaArc :: Creature -> World -> World
 aTeslaArc cr w 
    = teslaGunFlashAt (pos +.+ 5 *.* unitVectorAtAngle dir)
    $ set randGen g w
-    & particles %~ (makeTeslaArcAt pos dir :)
+    & particles %~ (makeTeslaArcAt col pos dir :)
  where 
-    pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir) 
-                    +.+ sideOffset *.* vNormal (unitVectorAtAngle dir)
-    (sideOffset,g) = randomR (-5,5) $ _randGen w
+    pos = _crPos cr +.+ (_crRad cr +1) *.* unitVectorAtAngle dir
    dir = _crDir cr
+    (colid,g) = randomR (0::Int,3) $ _randGen w
+    col = chooseColor colid
+    chooseColor 0 = white
+    chooseColor 1 = azure
+    chooseColor 2 = blue
+    chooseColor _ = cyan

 remoteShellPic' :: Projectile -> Picture
 remoteShellPic' pj
@@ -69,10 +69,6 @@ soundMenuOptions =
 pushMenu :: MenuLayer -> World -> Maybe World
 pushMenu ml w'   = Just $ w' & menuLayers %~ (ml :)

--soundOptions :: [MenuOption]
--soundOptions =
--    [ Toggle2 ScancodeY 
-
 graphicsMenuOptions :: [MenuOption]
 graphicsMenuOptions =
    [ Toggle ScancodeW (Just . (config . wall_textured %~ not))  wtextstring
@@ -100,8 +96,8 @@ pauseMenuOptions =

 startNewGame :: World -> Maybe World
 startNewGame w = Just $ w
-        & menuLayers .~ [WaitMessage "GENERATING..." 1]
-        & worldEvents .~ const aNewGame
+    & menuLayers .~ [WaitMessage "GENERATING..." 1]
+    & worldEvents .~ const aNewGame
  where
    aNewGame :: World
    aNewGame = updateFramebufferSize $ generateLevelFromRoomList levx $ initialWorld 
@@ -135,10 +135,11 @@ bulConCr' bt p cr w
 {- | Hitting wall effects: create a spark, damage blocks.  -}
 bulHitWall' :: Particle -> Point2 -> Wall -> World -> World
 bulHitWall' bt p x w = damageBlocksBy 5 x
-    $ createSpark 8 12 pOut (reflectDir x) Nothing
+    $ createSparkCol 8 theCol pOut (reflectDir x) Nothing
    $ set randGen g
    w
  where 
+    theCol = brightX 100 1.5 white
    sp = head $ _btTrail' bt
    pOut = p +.+ safeNormalizeV (sp -.- p)
    (a, g) = randomR (-0.2,0.2) $ _randGen w
@@ -197,10 +198,11 @@ hvBulHitWall' bt p x w =  damageBlocksBy 5 x $ set randGen g $ foldr ($) w (spar
    reflectDir wall = a + 
        argV (reflectIn (uncurry (-.-) (_wlLine wall)) (p -.- sp) )
    sv = unitVectorAtAngle $ reflectDir x
-    cs      = take 10 $ randomRs (0,11) $ _randGen w
+    cs'      = take 10 $ randomRs (0,11) $ _randGen w
+    cs      = map (brightX 100 1.5 . numColor) cs'
    ds      = randomRs (-0.7,0.7) $ _randGen w
    ts      = randomRs (4,8) $ _randGen w
-    sparks pos vel = zipWith3 (\t c d -> createSpark t c pos (argV vel + d) Nothing) ts cs ds
+    sparks pos vel = zipWith3 (\t c d -> createSparkCol t c pos (argV vel + d) Nothing) ts cs ds

 bulHitFF' :: Particle -> Point2 -> ForceField -> World -> World
 bulHitFF' _ _ _ = id
@@ -16,7 +16,7 @@ aGenBulAt
    -> HitEffect 
    -> Float    -- ^ Bullet width
    -> Particle
-aGenBulAt maycid pos vel hiteff width = Bul'
+aGenBulAt maycid pos vel hiteff width = BulletPt
    { _ptDraw = drawBul
    , _ptUpdate' = mvGenBullet
    , _btVel' = vel
@@ -35,7 +35,7 @@ aDelayedBulAt
    -> HitEffect 
    -> Float    -- ^ Bullet width
    -> Particle
-aDelayedBulAt vfact maycid pos vel hiteff width = Bul'
+aDelayedBulAt vfact maycid pos vel hiteff width = BulletPt
    { _ptDraw = drawBul
    , _ptUpdate' = \w -> resetVel . mvGenBullet w
    , _btVel' = vfact *.* vel
@@ -58,7 +58,7 @@ aCurveBulAt
    -> HitEffect 
    -> Float    -- ^ Bullet width
    -> Particle
-aCurveBulAt maycid col pos control targ hiteff width = Bul'
+aCurveBulAt maycid col pos control targ hiteff width = BulletPt
    { _ptDraw = drawBul
    , _ptUpdate' = \w -> mvGenBullet w . setVel
    , _btVel' = V2 0 0
@@ -8,8 +8,8 @@ module Dodge.Render.MenuScreen
 import Dodge.Data.Menu
 import Dodge.Data
 --import Dodge.Config.Update
-import Dodge.Config.Data
--import Dodge.Base (halfWidth,halfHeight)
+--import Dodge.Config.Data
+import Dodge.Base.Window
 import Picture
 import Geometry
 import Dodge.Menu
@@ -17,18 +17,15 @@ import Dodge.Menu

 menuScreen 
    :: World
-    -> Configuration 
-    -> Float    -- Half width of screen
-    -> Float    -- Half height of screen
    -> [MenuLayer]
    -> Picture
-menuScreen w cfig hw hh mLays = case mLays of
-    (LevelMenu x:_) -> optionsFromList w hw hh ("LEVEL"++show x) levelMenuOptions
-    (PauseMenu : _) -> optionsFromList w hw hh "PAUSED" pauseMenuOptions
-    (GameOverMenu : _) -> optionsFromList w hw hh "GAME OVER" pauseMenuOptions
-    (OptionMenu : _) -> optionsFromList w hw hh "OPTIONS" optionsOptions
-    (SoundOptionMenu : _) -> optionsFromList w hw hh "OPTIONS:VOLUME" soundMenuOptions
-    (GraphicsOptionMenu : _) -> optionsFromList w hw hh "OPTIONS:GRAPHICS" graphicsMenuOptions
+menuScreen w mLays = case mLays of
+    (LevelMenu x:_)     -> optionsFromList w ("LEVEL"++show x) levelMenuOptions
+    (PauseMenu : _)     -> optionsFromList w "PAUSED" pauseMenuOptions
+    (GameOverMenu : _)  -> optionsFromList w "GAME OVER" pauseMenuOptions
+    (OptionMenu : _)    -> optionsFromList w "OPTIONS" optionsOptions
+    (SoundOptionMenu : _) -> optionsFromList w "OPTIONS:VOLUME" soundMenuOptions
+    (GraphicsOptionMenu : _) -> optionsFromList w "OPTIONS:GRAPHICS" graphicsMenuOptions
    (ControlList : _) -> pictures 
        [color (withAlpha 0.5 black) $ polygon $ screenBox hw hh
        ,tst (-100) 100 0.4 "CONTROLS"
@@ -40,6 +37,8 @@ menuScreen w cfig hw hh mLays = case mLays of
    _ -> blank
  where 
    tst x y sc t = translate x y $ scale sc sc $ color white $ text t
+    hh = halfHeight w
+    hw = halfWidth  w

 displayStringList :: Float -> Float -> [String] -> Picture
 displayStringList hw hh ss = pictures
@@ -52,12 +51,10 @@ displayStringList hw hh ss = pictures
    
 optionsFromList
    :: World
-    -> Float    -- ^ Half screen width
-    -> Float    -- ^ Half screen height
    -> String   -- ^ Title
    -> [MenuOption] -- ^ Options
    -> Picture
-optionsFromList w hw hh tit ops = pictures $
+optionsFromList w title ops = pictures $
    [darkenBackground
    ,theTitle]
    ++
@@ -68,7 +65,9 @@ optionsFromList w hw hh tit ops = pictures $
    notInvisible _ = True
    placeString x y sc t = translate x y $ scale sc sc $ color white $ text t
    darkenBackground = color (withAlpha 0.5 black) $ polygon $ screenBox hw hh
-    theTitle = placeString (-hw + 30) (hh - 50) 0.4 tit
+    theTitle = placeString (-hw + 30) (hh - 50) 0.4 title
+    hh = halfHeight w
+    hw = halfWidth w
 menuOptionToString :: World -> MenuOption -> String
 menuOptionToString w mo@(Toggle{})
    = (scodeToChar $ _moKey mo) : ':' : _moString mo w
@@ -50,7 +50,7 @@ fixedCoordPictures w = case _menuLayers w of
        [ hudDrawings w
        , customMouseCursor w
        ]
-    lays -> scaler . onLayer MenuDepth $ menuScreen w (_config w) (halfWidth w) (halfHeight w) lays
+    lays -> scaler . onLayer MenuDepth $ menuScreen w lays
  where 
    scaler = setDepth (-1) . scale (2 / getWindowX w) (2 / getWindowY w)

@@ -33,7 +33,7 @@ createBarrelSpark :: Point2 -> Float -> Maybe Int -> Int -> Int -> World -> Worl
 createBarrelSpark pos dir maycid time colid w 
    = over worldEvents (( over particles (spark :) . sparkFlashAt pos') . ) w
  where 
-    spark = Bul'  
+    spark = BulletPt  
        { _ptDraw = drawBul
        , _ptUpdate' = mvGenBullet
        , _btVel' = rotateV dir (V2 5 0)
@@ -14,7 +14,7 @@ import Dodge.Picture
 import Dodge.WorldEvent.HitEffect
 import Dodge.WorldEvent.ThingsHit
 import Dodge.WorldEvent.Cloud
-import Dodge.WorldEvent.Flash
+--import Dodge.WorldEvent.Flash
 import Dodge.Particle.Bullet.Draw
 import Dodge.Particle.Bullet.Update
 import Dodge.SoundLogic
@@ -41,7 +41,7 @@ aFlameParticle
    -> Point2   -- ^ Velocity
    -> Maybe Int -- ^ Creature id
    -> Particle
-aFlameParticle t pos vel maycid = Pt'
+aFlameParticle t pos vel maycid = PtZ
    { _ptDraw         = drawFlame vel
    , _ptUpdate'      = moveFlame vel
    , _btVel'         = vel
@@ -51,10 +51,12 @@ aFlameParticle t pos vel maycid = Pt'
    , _btWidth'       = 4
    , _btTimer'       = t
    , _btHitEffect'   = destroyOnImpact (doFlameDam 1) noEff noEff
+    , _ptZ            = 20
    }
 drawFlame 
    :: Point2 -- ^ Rotate direction
-    -> Particle -> Picture
+    -> Particle 
+    -> Picture
 drawFlame rotd pt = thePic
  where
    ep = _btPos' pt
@@ -300,13 +302,13 @@ cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedC
    damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint (stripZ $ _clPos c) w
    f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < _crRad cr + _clRad c + 10
    doDam cr = cr & crState . crDamage %~ (:) (PoisonDam 1)
-makeTeslaArcAt :: Point2 -> Float -> Particle
-makeTeslaArcAt pos dir = LinearParticle
+makeTeslaArcAt :: Color -> Point2 -> Float -> Particle
+makeTeslaArcAt col pos dir = LinearParticle
    { _ptPoints = [pos]
    , _ptDraw = drawTeslaArc
    , _ptUpdate' = moveTeslaArc pos dir
    , _ptTimer = 2
-    , _ptColor = white
+    , _ptColor = brightX 100 1.5 col
    }
 drawTeslaArc :: Particle -> Picture
 drawTeslaArc pt = pic
@@ -328,10 +330,11 @@ moveTeslaArc
 moveTeslaArc p d w pt
    | t == 2 = 
        (foldr damCrs w hitCrs & randGen .~ g
-            & createSpark 8 nc q2 (argV sv + d1) Nothing
-        , Just $ pt & ptTimer -~ 1
-                            & ptPoints .~ ps'
-                            & ptColor .~ theColor)
+            & createSparkCol 8 nc q2 (argV sv + d1) Nothing
+        , Just $ pt 
+            & ptTimer -~ 1
+            & ptPoints .~ ps'
+        )
    | t < 1 = (w , Nothing)
    | otherwise = (w , Just $ pt & ptTimer -~ 1)
 where 
@@ -342,11 +345,8 @@ moveTeslaArc p d w pt
    f (E3x3 p1) = p1
    ps' = lightningMids d pers ps
    pers = evalState (sequence $ repeat $ randInCirc 5) $ _randGen w
-    (nc,g) = randomR (0::Int,5) $ _randGen w
-    theColor = f2 nc
-    f2 0 = cyan
-    f2 1 = azure
-    f2 _ = white
+    nc = brightX 100 1.5 $ numColor colid
+    (colid,g) = randomR (0::Int,5) $ _randGen w
    f1 (E3x1 cr) = Just $ _crID cr
    f1 _         = Nothing
    hitCrs       = mapMaybe f1 $ take 14 $ crsLightChain p d 0 w
@@ -453,32 +453,11 @@ crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (V2 arcLen 0))
 -- | Create a spark. 
 -- If the spark is created by another Particle, it cannot be directly added to
 -- the list, hence the redirect through worldEvents.
-createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
-createSpark time colid pos dir maycid w 
-    = w & worldEvents %~ ( (over particles (spark :) . sparkFlashAt pos') . )
-  where 
-    spark = Bul'
-        { _ptDraw = drawBul
-        , _ptUpdate' = mvGenBullet
-        , _btVel' = rotateV dir (V2 5 0)
-        , _btColor' = brightX 100 1.5 $ numColor colid
-        , _btTrail' = [pos]
-        , _btPassThrough' = maycid
-        , _btWidth' = 1
-        , _btTimer' = time
-        , _btHitEffect' = destroyOnImpact sparkEff noEff noEff
-        }
-    pos' = pos +.+ rotateV dir (V2 5 0)
-    sparkEff bt p cr
-        = creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : )
-      where 
-        sp = head (_btTrail' bt)
-        ep = sp +.+ _btVel' bt
 createSparkCol :: Int -> Color -> Point2 -> Float -> Maybe Int -> World -> World
 createSparkCol time col pos dir maycid w 
-    = w & worldEvents %~ ( (over particles (spark :) . sparkFlashAt pos') . )
+    = w & worldEvents %~ ( over particles (spark :) . )
  where 
-    spark = Bul'
+    spark = BulletPt
        { _ptDraw = drawBul
        , _ptUpdate' = mvGenBullet
        , _btVel' = rotateV dir (V2 5 0)
@@ -489,7 +468,6 @@ createSparkCol time col pos dir maycid w
        , _btTimer' = time
        , _btHitEffect' = destroyOnImpact sparkEff noEff noEff
        }
-    pos' = pos +.+ rotateV dir (V2 5 0)
    sparkEff bt p cr
        = creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : )
      where