diff --git a/src/Dodge/Item/Weapon/Bullet.hs b/src/Dodge/Item/Weapon/Bullet.hs index c50d799ad..71005ad80 100644 --- a/src/Dodge/Item/Weapon/Bullet.hs +++ b/src/Dodge/Item/Weapon/Bullet.hs @@ -22,7 +22,7 @@ ltBullet = BulletAmmo hvBullet :: Ammo hvBullet = BulletAmmo { _amString = "HVBULLET" - , _amBulEff = penWalls hvBulHitCr hvBulHitWall' + , _amBulEff = penWalls hvBulHitCr hvBulHitWall , _amBulWth = 6 , _amBulVel = V2 80 0 } diff --git a/src/Dodge/Particle/Bullet/HitEffect.hs b/src/Dodge/Particle/Bullet/HitEffect.hs index 36d5efe0e..09ae28df0 100644 --- a/src/Dodge/Particle/Bullet/HitEffect.hs +++ b/src/Dodge/Particle/Bullet/HitEffect.hs @@ -1,5 +1,5 @@ {- | -Effects of bullets upon impact with walls or creatures, and possibly force fields. +Effects of bullets upon impact with walls or creatures. -} module Dodge.Particle.Bullet.HitEffect where @@ -22,9 +22,6 @@ import Picture import System.Random import Control.Lens import Control.Monad.State ---import Data.Maybe ---import qualified Data.IntMap.Strict as IM --- -- | Basic bullet hit creature effect. bulHitCr :: Particle -> Point2 -> Creature -> World -> World bulHitCr bt p cr w @@ -187,14 +184,13 @@ bulConWall' bulConWall' _ p wl = damageBlocksBy 1 wl . over worldEvents ( makeShockwaveAt [] p 15 4 1 white . ) - -hvBulHitWall' +hvBulHitWall :: Particle -> Point2 -- ^ Impact point -> Wall -> World -> World -hvBulHitWall' bt p x w = damageBlocksBy 5 x $ set randGen g $ foldr ($) w (sparks pOut sv) +hvBulHitWall bt p x w = damageBlocksBy 5 x $ set randGen g $ foldr ($) w (sparks pOut sv) where sp = head $ _btTrail' bt pOut = p +.+ safeNormalizeV (sp -.- p) diff --git a/src/Dodge/Particle/Bullet/Spawn.hs b/src/Dodge/Particle/Bullet/Spawn.hs index 8eaec7d20..432c9db24 100644 --- a/src/Dodge/Particle/Bullet/Spawn.hs +++ b/src/Dodge/Particle/Bullet/Spawn.hs @@ -1,5 +1,8 @@ module Dodge.Particle.Bullet.Spawn - where + ( aGenBulAt + , aDelayedBulAt + , aCurveBulAt + ) where import Dodge.Data import Dodge.Particle.Bullet.Draw import Dodge.Particle.Bullet.Update diff --git a/src/Dodge/Particle/Bullet/Update.hs b/src/Dodge/Particle/Bullet/Update.hs index c0a18823c..f093dedd8 100644 --- a/src/Dodge/Particle/Bullet/Update.hs +++ b/src/Dodge/Particle/Bullet/Update.hs @@ -1,8 +1,7 @@ -{- -Bullet update. - -} +{- Bullet update. -} module Dodge.Particle.Bullet.Update - where + ( mvGenBullet + ) where import Dodge.Data --import Dodge.Base import Dodge.WorldEvent.ThingsHit @@ -10,20 +9,16 @@ import Dodge.WorldEvent.ThingsHit import Geometry import Control.Lens ---import Data.Maybe ---import Data.List ---import Data.Bifunctor ---import qualified Data.IntMap.Strict as IM - {- Update for a generic bullet. -} mvGenBullet :: World -> Particle -> (World, Maybe Particle) mvGenBullet w bt | t <= 0 = (w, Nothing) - | t < 4 = (w, Just $ set btPassThrough' Nothing - $ set btTrail' (p:p:ps) - $ set btTimer' (t-1) bt + | t < 4 = (w, Just $ bt + & btPassThrough' .~ Nothing + & btTrail' .~ (p:p:ps) + & btTimer' -~ 1 ) | otherwise = hiteff bt (thingsHitExceptCr mcr p (p +.+ vel) w) w where diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 5dfcdb8a5..faab3f6fd 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -27,15 +27,13 @@ hudDrawings w = pictures , selectionText ] where - selectionText = - if _carteDisplay w + selectionText = if _carteDisplay w then drawLocations w else drawInventory w drawInventory :: World -> Picture -drawInventory w = subInventoryDisplay w - `appendPic` displayInv 0 w +drawInventory w = subInventoryDisplay w `appendPic` displayInv 0 w subInventoryDisplay :: World -> Picture subInventoryDisplay w = case _inventoryMode w of diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 10ac06870..e656a38aa 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -1,4 +1,8 @@ module Dodge.Render.List + ( renderListAt + , dShadCol + , winScale + ) where import Dodge.Data import Dodge.Base.Window @@ -21,6 +25,7 @@ listPairAt xoff yoff w yint (s,col) . scale 0.1 0.1 . dShadCol col $ text s +--TODO put the following functions in an appropriate place {- | Colour picture and add black drop shadow. -} dShadCol :: Color -> Picture -> Picture {-# INLINE dShadCol #-} diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index c8def0c5f..63a2c2df7 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -1,6 +1,4 @@ -{- -The menu picture. - -} +{- The menu picture. -} module Dodge.Render.MenuScreen ( menuScreen ) diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 810193222..534e6dc80 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -1,6 +1,10 @@ --{-# LANGUAGE TupleSections #-} module Dodge.Render.Picture - where + ( worldPictures + , wallsAndWindows + , lightsForGloom + , fixedCoordPictures + ) where import Dodge.Data --import Dodge.Update.Camera --import Dodge.GameRoom @@ -126,6 +130,15 @@ wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w | wl ^? wlDraw == Just False = False | otherwise = onScreen wl +lineOnScreen :: World -> Point2 -> Point2 -> Bool +lineOnScreen w p1 p2 = pointInPolygon p1 sp + || pointInPolygon p2 sp + || any (isJust . uncurry (intersectSegSeg p1 p2)) sps + where + sp = screenPolygon w + sps = zip sp (tail sp ++ [head sp]) + + drawWallFloor :: Wall -> Picture drawWallFloor wl = if _wlIsSeeThrough wl then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y] @@ -139,77 +152,6 @@ errorNormalizeVDR :: Point2 -> Point2 errorNormalizeVDR (V2 0 0) = error "problem with function: errorNormalizeVDR in DodgeRendering" errorNormalizeVDR p = normalizeV p -printPoint :: Point2 -> Picture -printPoint p = color white $ uncurryV translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)] - -printRotPoint :: Float -> Point2 -> Picture -printRotPoint r p = color white - . uncurryV translate p - $ pictures [circle 3 , rotate (negate r) $ scale 0.1 0.1 $ text (show p)] - -outsideScreenPolygon :: World -> [Point2] -outsideScreenPolygon w = [tr,tl,bl,br] - where - scRot = rotateV (_cameraRot w) - scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p - | otherwise = error "Trying to set screen zoom to zero" - scTran p = p +.+ _cameraCenter w - tr = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) ( 3* halfHeight w) - tl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) ( 3* halfHeight w) - br = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) (- (3* halfHeight w)) - bl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) (- (3* halfHeight w)) - --- cannot only test if walls are on screen, but also if they are on the cone --- towards the center of sight -lineOnScreenCone :: World -> Point2 -> Point2 -> Bool -lineOnScreenCone w p1 p2 = pointInPolygon p1 sp - || pointInPolygon p2 sp - || any (isJust . uncurry (intersectSegSeg p1 p2)) sps - where - sp' = screenPolygon w - vp = _cameraViewFrom w - sp | pointInPolygon vp sp' = sp' - | otherwise = orderPolygon (_cameraViewFrom w : sp') - sps = zip sp (tail sp ++ [head sp]) - - -lineOnScreen :: World -> Point2 -> Point2 -> Bool -lineOnScreen w p1 p2 = pointInPolygon p1 sp - || pointInPolygon p2 sp - || any (isJust . uncurry (intersectSegSeg p1 p2)) sps - where - sp = screenPolygon w - sps = zip sp (tail sp ++ [head sp]) - -drawWallFace :: World -> Wall -> Picture -drawWallFace w wall - | isRHS sightFrom x y || _wlIsSeeThrough wall = blank - | otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points - where - (x,y) = _wlLine wall - points = extendConeToScreenEdge w sightFrom (x,y) - sightFrom = _cameraViewFrom w - --- the following assumes that the point a is inside the screen --- it still works otherwise, but it might intersect two points: --- it is not obvious which will be returned -intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2 -intersectLinefromScreen w a b = listToMaybe - . mapMaybe (\(x,y) -> intersectSegLineFrom' x y b (b +.+ b -.- a)) - . makeLoopPairs - $ screenPolygon w - -extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2] -extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs - where - borderPs = mapMaybe (intersectLinefromScreen w c) [x,y] - cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w - wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg y ((2*.*y) -.- x)) - . makeLoopPairs $ screenPolygon w - -rectangleSolid :: Float -> Float -> Picture -rectangleSolid x y = polygon $ map toV2 [(x,y),(x,-y),(-x,-y),(-x,y)] - wallsAndWindows :: World -> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)] ) @@ -219,9 +161,6 @@ wallsAndWindows w f wl = (_wlLine wl, _wlColor wl) (wins,wls) = partition _wlIsSeeThrough . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen w -wallsToList :: [((Point2,Point2),Point4)] -> [Float] -wallsToList = concatMap (\((V2 a b,V2 c d),V4 e f g h) -> [a,b,c,d,e,f,g,h]) - lightsForGloom :: World -> [(Point3,Float,Point3)] lightsForGloom w = mapMaybe getLS (IM.elems $ _lightSources w) ++ mapMaybe getTLS (_tempLightSources w) where diff --git a/src/Dodge/Render/Shape.hs b/src/Dodge/Render/Shape.hs index f0d6bd5f0..d84149197 100644 --- a/src/Dodge/Render/Shape.hs +++ b/src/Dodge/Render/Shape.hs @@ -1,5 +1,6 @@ module Dodge.Render.Shape - where + ( worldShape + ) where import Dodge.Data import Dodge.Base import Shape diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index b982afb66..0cbf9e581 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -1,11 +1,16 @@ module Dodge.Render.ShapePicture + ( floorItemSPic + ) where import Dodge.Data import Geometry import ShapePicture +--import Shape +--import Picture floorItemSPic :: FloorItem -> SPic floorItemSPic flit = uncurryV translateSPf (_flItPos flit) $ rotateSP (_flItRot flit) (_itFloorPict (_flIt flit) (_flIt flit)) +--TODO combine worldShape and worldPicture here diff --git a/src/Dodge/SoundLogic/LoadSound.hs b/src/Dodge/SoundLogic/LoadSound.hs index 7f5900962..703edd411 100644 --- a/src/Dodge/SoundLogic/LoadSound.hs +++ b/src/Dodge/SoundLogic/LoadSound.hs @@ -1,4 +1,5 @@ -module Dodge.SoundLogic.LoadSound where +module Dodge.SoundLogic.LoadSound + where import Sound.Data import qualified Data.IntMap.Strict as IM