From 451ef98b9f1f5acfef3fcc9b141762d31884c704 Mon Sep 17 00:00:00 2001 From: jgk Date: Tue, 23 Mar 2021 15:48:14 +0100 Subject: [PATCH] General cleanup, remove Drawing type synonym --- src/Dodge/Base.hs | 3 -- src/Dodge/CreatureState.hs | 6 ++-- src/Dodge/Critters.hs | 8 ++--- src/Dodge/Data.hs | 56 ++++++++++++++++----------------- src/Dodge/Item/Draw.hs | 2 +- src/Dodge/LevelGen.hs | 2 +- src/Dodge/Rendering.hs | 12 +++---- src/Dodge/WorldEvent/Flash.hs | 59 ++++++++++++++++++++++++++++++++++- 8 files changed, 100 insertions(+), 48 deletions(-) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index fc0fef4be..e74b5ee91 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -760,9 +760,6 @@ wallsLOS :: Foldable t => t [Point2] -> Point2 -> Point2 -> Bool {-# INLINE wallsLOS #-} wallsLOS !ls !c !p = all (\l -> wallLOS l c p) ls -translateDrawing = translate -rotateDrawing = rotate - mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2 mvPointTowardAtSpeed speed !ep !p | dist p ep < speed = ep diff --git a/src/Dodge/CreatureState.hs b/src/Dodge/CreatureState.hs index 0d0dd17ae..40e47ac6e 100644 --- a/src/Dodge/CreatureState.hs +++ b/src/Dodge/CreatureState.hs @@ -9,6 +9,7 @@ import Dodge.WallCreatureCollisions import Dodge.CreatureAction import Geometry +import Picture import Data.List import Data.Char @@ -54,9 +55,8 @@ stateUpdate u w (f,g) cr = case u w (f,g) (updateMovement g cr) of . over decorations addCorpse . insertIt crBeforeDeath = colCrWall w $ cr --- addCorpse = insertNewKey $ uncurry translateDrawing (_crPos crBeforeDeath) - addCorpse = insertNewKey $ uncurry translateDrawing (_crOldPos cr) - $ rotateDrawing (radToDeg (_crDir cr)) + addCorpse = insertNewKey $ uncurry translate (_crOldPos cr) + $ rotate (_crDir cr) (_crCorpse cr) maybeIt = evalState (maybeTakeOne $ IM.elems (_crInv cr)) (_randGen w) insertIt = case maybeIt of diff --git a/src/Dodge/Critters.hs b/src/Dodge/Critters.hs index 9282f1909..a5be2cc43 100644 --- a/src/Dodge/Critters.hs +++ b/src/Dodge/Critters.hs @@ -252,11 +252,11 @@ explosiveBarrel = basicCreature , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] } -equipOnTop :: (Creature -> Picture) -> Creature -> Drawing +equipOnTop :: (Creature -> Picture) -> Creature -> Picture --equipOnTop f cr = onLayer CrLayer $ pictures $ fst (drawEquipment cr) ++ [f cr] ++ snd (drawEquipment cr) equipOnTop f cr = pictures [onLayer CrLayer (f cr) , drawEquipment cr] -drawEquipment :: Creature -> Drawing +drawEquipment :: Creature -> Picture drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr) where f (i,it) = case it ^? itEquipPict of Just g -> g cr i @@ -367,7 +367,7 @@ startCr = basicCreature smokeGenGun = effectGun "smoke" $ \_ -> spawnSmokeAtCursor -enemyPict :: Color -> Creature -> Drawing +enemyPict :: Color -> Creature -> Picture enemyPict col = equipOnTop $ sizeEnemy (light $ light $ light $ light col) sizeEnemy col cr @@ -380,7 +380,7 @@ sizeEnemy col cr sizeColEnemy r col = pictures [color col $ circleSolid r, circLine r] -basicCrPict :: Color -> Creature -> Drawing +basicCrPict :: Color -> Creature -> Picture basicCrPict col cr = pictures [ onLayer CrLayer naked , drawEquipment cr] where naked | pdam > 200 = color red $ circleSolid $ _crRad cr | pdam > 100 = color white $ circleSolid $ _crRad cr diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index b90b597ac..0d5aa5401 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -64,7 +64,7 @@ data World = World , _buttons :: IM.IntMap Button , _soundQueue :: [Int] , _sounds :: M.Map SoundOrigin Sound - , _decorations :: IM.IntMap Drawing + , _decorations :: IM.IntMap Picture , _corpses :: IM.IntMap (IM.IntMap [Corpse]) , _lbClickMousePos :: (Float,Float) , _lbRotation :: Float @@ -84,11 +84,9 @@ data World = World , _remap :: Keycode -> Keycode } --deriving (Show) -type Drawing = Picture - data Corpse = Corpse { _cpPos :: Point2 - , _cpPict :: Drawing + , _cpPict :: Picture , _cpRes :: Creature } @@ -103,7 +101,7 @@ data Cloud = Cloud { _clID :: Int , _clPos :: Point2 , _clVel :: Point2 - , _clPict :: Cloud -> Drawing + , _clPict :: Cloud -> Picture , _clRad :: Float , _clTimer :: Int , _clEffect :: Cloud -> World -> World @@ -130,7 +128,7 @@ data Creature = Creature , _crOldPos :: Point2 , _crDir :: Float , _crID :: Int - , _crPict :: Creature -> Drawing + , _crPict :: Creature -> Picture , _crUpdate :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) , _crRad :: Float @@ -140,7 +138,7 @@ data Creature = Creature , _crInv :: IM.IntMap Item , _crInvSel :: Int , _crState :: CreatureState - , _crCorpse :: Drawing + , _crCorpse :: Picture } data CreatureState @@ -243,7 +241,7 @@ data MenuState deriving (Eq,Ord) data Button = Button - { _btPict :: Drawing + { _btPict :: Picture , _btPos :: Point2 , _btRot :: Float , _btEvent :: Button -> World -> World @@ -255,7 +253,7 @@ data Button = Button data ButtonState = BtOn | BtOff | BtNoLabel deriving (Eq, Show) -data PressPlate = PressPlate { _ppPict :: Drawing +data PressPlate = PressPlate { _ppPict :: Picture , _ppPos :: Point2 , _ppRot :: Float , _ppEvent :: PressPlate -> World -> World @@ -283,13 +281,13 @@ data Item = Weapon , _wpSpread :: Float , _wpRange :: Float , _itHammer :: HammerPosition - , _itFloorPict :: Drawing + , _itFloorPict :: Picture , _itMaxStack :: Int , _itAmount :: Int , _itAimingSpeed :: Float , _itAimingRange :: Float , _itZoom :: ItZoom - , _itEquipPict :: Creature -> Int -> Drawing + , _itEquipPict :: Creature -> Int -> Picture , _itScrollUp :: Int -> World -> World , _itScrollDown :: Int -> World -> World , _itIdentity :: ItemIdentity @@ -304,8 +302,8 @@ data Item = Weapon , _itMaxStack :: Int , _itAmount :: Int , _cnEffect :: Int -> World -> Maybe World - , _itFloorPict :: Drawing - , _itEquipPict :: Creature -> Int -> Drawing + , _itFloorPict :: Picture + , _itEquipPict :: Creature -> Int -> Picture , _itIdentity :: ItemIdentity , _itID :: Maybe Int , _itInvDisplay :: Item -> String @@ -317,8 +315,8 @@ data Item = Weapon { _itName :: String , _itMaxStack :: Int , _itAmount :: Int - , _itFloorPict :: Drawing - , _itEquipPict :: Creature -> Int -> Drawing + , _itFloorPict :: Picture + , _itEquipPict :: Creature -> Int -> Picture , _itIdentity :: ItemIdentity , _itID :: Maybe Int , _itInvDisplay :: Item -> String @@ -328,8 +326,8 @@ data Item = Weapon { _itName :: String , _itMaxStack :: Int , _itAmount :: Int - , _itFloorPict :: Drawing - , _itEquipPict :: Creature -> Int -> Drawing + , _itFloorPict :: Picture + , _itEquipPict :: Creature -> Int -> Picture , _itIdentity :: ItemIdentity , _itEffect :: ItEffect , _itID :: Maybe Int @@ -344,14 +342,14 @@ data Item = Weapon { _itName :: String , _itMaxStack :: Int , _itAmount :: Int - , _itFloorPict :: Drawing + , _itFloorPict :: Picture , _twMaxRange :: Float , _twAccuracy :: Float , _twFire :: Int -> World -> World , _itAimingSpeed :: Float , _itAimingRange :: Float , _itZoom :: ItZoom - , _itEquipPict :: Creature -> Int -> Drawing + , _itEquipPict :: Creature -> Int -> Picture , _itIdentity :: ItemIdentity , _itID :: Maybe Int , _itAttachment :: Maybe ItAttachment @@ -432,10 +430,10 @@ data ItemIdentity data Particle' = Particle' - { _ptPict' :: Drawing + { _ptPict' :: Picture , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle') } - | Bul' { _ptPict' :: Drawing + | Bul' { _ptPict' :: Picture , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle') , _btVel' :: Point2 , _btColor' :: Color @@ -445,7 +443,7 @@ data Particle' = , _btTimer' :: Int , _btHitEffect' :: HitEffect } - | Pt' { _ptPict' :: Drawing + | Pt' { _ptPict' :: Picture , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle') , _btVel' :: Point2 , _btColor' :: Color @@ -456,7 +454,7 @@ data Particle' = , _btHitEffect' :: HitEffect } | Shockwave' - { _ptPict' :: Drawing + { _ptPict' :: Picture , _ptUpdate' :: World -> Particle' -> (World, Maybe Particle') , _btColor' :: Color , _btPos' :: Point2 @@ -479,7 +477,7 @@ data Projectile = Projectile { _ptPos :: Point2 , _ptStartPos :: Point2 , _ptVel :: Point2 - , _ptPict :: Drawing + , _ptPict :: Picture , _ptID :: Int , _ptUpdate :: World -> World } @@ -515,7 +513,7 @@ data Wall = Wall { _wlLine :: [Point2] , _wlID :: Int , _wlColor :: Color - , _wlDraw :: Maybe (Wall -> Drawing) + , _wlDraw :: Maybe (Wall -> Picture) , _wlSeen :: Bool , _wlIsSeeThrough :: Bool } @@ -524,7 +522,7 @@ data Wall , _wlID :: Int , _doorMech :: World -> World , _wlColor :: Color - , _wlDraw :: Maybe (Wall -> Drawing) + , _wlDraw :: Maybe (Wall -> Picture) , _wlSeen :: Bool , _blIDs :: [Int] , _blHP :: Int @@ -534,7 +532,7 @@ data Wall { _wlLine :: [Point2] , _wlID :: Int , _doorMech :: World -> World , _wlColor :: Color - , _wlDraw :: Maybe (Wall -> Drawing) + , _wlDraw :: Maybe (Wall -> Picture) , _wlSeen :: Bool , _wlIsSeeThrough :: Bool , _doorPathable :: Bool @@ -543,7 +541,7 @@ data Wall { _wlLine :: [Point2] , _wlID :: Int , _wlColor :: Color - , _wlDraw :: Maybe (Wall -> Drawing) + , _wlDraw :: Maybe (Wall -> Picture) , _wlSeen :: Bool , _blIDs :: [Int] , _blHP :: Int @@ -579,7 +577,7 @@ data SoundOrigin = InventorySound type Poly = [Point2] data PSType = PutCrit Creature - | PutLS LightSource Drawing + | PutLS LightSource Picture | PutButton Button | PutFlIt FloorItem | PutPressPlate PressPlate diff --git a/src/Dodge/Item/Draw.hs b/src/Dodge/Item/Draw.hs index 75fa6323e..39e825c01 100644 --- a/src/Dodge/Item/Draw.hs +++ b/src/Dodge/Item/Draw.hs @@ -5,7 +5,7 @@ import Dodge.Base import Picture -drawWeapon :: Picture -> Creature -> Int -> Drawing +drawWeapon :: Picture -> Creature -> Int -> Picture drawWeapon p cr posInInv | _crInvSel cr == posInInv = onLayer PtLayer drawnWep | otherwise = blank diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index ccea00965..3ac8c5b61 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -151,7 +151,7 @@ placeCr crF p rot w = over creatures addCr w (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs}) crs -placeLS :: LightSource -> Drawing -> Point2 -> Float -> World -> World +placeLS :: LightSource -> Picture -> Point2 -> Float -> World -> World placeLS ls dec p rot w = over lightSources addLS $ over decorations addDec w where addLS lss = IM.insert (newKey lss) diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index 6cfa87e8e..f2c7ad233 100644 --- a/src/Dodge/Rendering.hs +++ b/src/Dodge/Rendering.hs @@ -55,14 +55,14 @@ testPic w = [blank] -- $ uncurry translate (mouseWorldPos w) -crDraw :: Creature -> Drawing +crDraw :: Creature -> Picture crDraw c = uncurry translate (_crPos c) $ rotate (_crDir c) (_crPict c c) -ppDraw :: PressPlate -> Drawing +ppDraw :: PressPlate -> Picture ppDraw c = uncurry translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c) -btDraw :: Button -> Drawing +btDraw :: Button -> Picture btDraw c = uncurry translate (_btPos c) $ rotate (_btRot c) (_btPict c) -clDraw :: Cloud -> Drawing +clDraw :: Cloud -> Picture clDraw c = uncurry translate (_clPos c) $ (_clPict c c) @@ -204,9 +204,9 @@ extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] + rectangleSolid x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)] -drawItem :: FloorItem -> Drawing +drawItem :: FloorItem -> Picture drawItem flIt = uncurry translate (_flItPos flIt) - $ rotateDrawing (radToDeg $ _flItRot flIt) (_itFloorPict (_flIt flIt)) + $ rotate (_flItRot flIt) (_itFloorPict (_flIt flIt)) ffToDraw :: World -> [ForceField] diff --git a/src/Dodge/WorldEvent/Flash.hs b/src/Dodge/WorldEvent/Flash.hs index 2227debe9..972b742ec 100644 --- a/src/Dodge/WorldEvent/Flash.hs +++ b/src/Dodge/WorldEvent/Flash.hs @@ -22,6 +22,29 @@ lowLightColAt :: Color -> Float -> Point2 -> World -> World lowLightColAt col alphay p w = foldr (lowLightWidthHit 10 5 col alphay p) w ps where ps = map ((+.+) p) $ nRaysRad 20 30 +lowLightWidthForHit :: Float -> Float -> Color -> Float -> Int -> Point2 -> Point2 -> World -> World +lowLightWidthForHit len wdth col alphay t a b w + = case thingsHitLongLine a b w of + ((p, E3x2 wall):_) + -> over particles' ((:) (wallGlareFor t len wdth col alphay p wall)) w + ((p, E3x1 cr):_) + -> over particles' ((:) (crGlareFor t wdth col alphay p cr)) w + _ -> w + +lowLightPic :: Float -> Float -> Color -> Float -> Point2 -> Point2 -> World -> Picture +lowLightPic len wdth col alphay a b w + = case thingsHitLongLine a b w of + ((p, E3x2 wall):_) + -> setCol . lineOfThickness wdth $ [p +.+ x, p -.- x] + where x = len *.* (normalizeV $ wa -.- wb) + (wa:wb:_) = _wlLine wall + ((p, E3x1 cr):_) + -> setCol . uncurry translate cp . rotate (-0.25 * pi + argV (p -.- cp)) + $ thickArc 0 (pi/2) (_crRad cr) wdth + where cp = _crPos cr + _ -> blank + where setCol = color (withAlpha alphay col) . setDepth 0 . setLayer 1 + lowLightWidthHit :: Float -> Float -> Color -> Float -> Point2 -> Point2 -> World -> World lowLightWidthHit len wdth col alphay a b w = case thingsHitLongLine a b w of @@ -41,6 +64,15 @@ flashColAt col alphax (x,y) = [20,25,30,35,40,45,50] , _ptUpdate' = ptTimer' 1 } +wallGlareFor :: Int -> Float -> Float -> Color -> Float -> Point2 -> Wall -> Particle' +wallGlareFor t len wdth col alphay p wl = + Particle' + { _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l + , _ptUpdate' = ptTimer' t + } + where l = color (withAlpha alphay col) $ lineOfThickness wdth $ [p +.+ x, p -.- x] + x = len *.* ( normalizeV $ a -.- b) + (a:b:_) = _wlLine wl wallGlareWidth :: Float -> Float -> Color -> Float -> Point2 -> Wall -> Particle' wallGlareWidth len wdth col alphay p wl = @@ -52,6 +84,25 @@ wallGlareWidth len wdth col alphay p wl = x = len *.* ( normalizeV $ a -.- b) (a:b:_) = _wlLine wl +crGlareFor :: Int -> Float -> Color -> Float -> Point2 -> Creature -> Particle' +crGlareFor t wdth col alphay p cr = + Particle' + { _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l cp + , _ptUpdate' = \w pt -> (w, Just $ pt {_ptPict' = onLayerL [levLayer GloomLayer + 2] $ upp cid w + ,_ptUpdate' = ptTimer' (t - 1) + } + ) + } + where l x = uncurry translate x + $ rotate (-0.25*pi + argV (p -.- x)) + $ color (withAlpha alphay col) + $ thickArc 0 (pi/2) (_crRad cr) wdth + cp = _crPos cr + cid = _crID cr + upp cid' w' = case w' ^? creatures . ix cid . crPos of + Just y -> l y + _ -> blank + crGlareWidth :: Float -> Color -> Float -> Point2 -> Creature -> Particle' crGlareWidth wdth col alphay p cr = Particle' @@ -96,9 +147,15 @@ lowLightWidthAt :: Float -> Float -> Color -> Float -> Int -> Float -> Point2 -> lowLightWidthAt len wdth col alphay rays rad p w = foldr (lowLightWidthHit len wdth col alphay p) w ps where ps = map ((+.+) p) $ nRaysRad rays rad +lowLightAtFor :: Float -> Float -> Color -> Float -> Int -> Float -> Point2 -> Int -> World -> World +lowLightAtFor len wdth col alphay rays rad p t w + = foldr (lowLightWidthForHit len wdth col alphay t p) w ps + where ps = map ((+.+) p) $ nRaysRad rays rad + + explosionFlashAt :: Point2 -> World -> World explosionFlashAt p = over tempLightSources ((:) $ tLightFade 20 150 intensityFunc p) - . lowLightWidthAt 10 5 white 0.3 75 150 p + . lowLightAtFor 10 5 white 0.3 75 150 p 20 where intensityFunc x | x < 10 = 1 / (10 - fromIntegral x) | otherwise = 1