From 769242111206576c6ff2a25f886647d4e6d59f0f Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 1 Nov 2021 02:15:22 +0000 Subject: [PATCH] Reorganise render collections --- src/Dodge/Render.hs | 5 +- src/Dodge/Render/Lights.hs | 20 +++++ src/Dodge/Render/Picture.hs | 148 +------------------------------ src/Dodge/Render/Shape.hs | 33 ------- src/Dodge/Render/ShapePicture.hs | 37 +++++++- src/Dodge/Render/Walls.hs | 19 ++++ 6 files changed, 76 insertions(+), 186 deletions(-) create mode 100644 src/Dodge/Render/Lights.hs delete mode 100644 src/Dodge/Render/Shape.hs create mode 100644 src/Dodge/Render/Walls.hs diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index e142dd8c1..cea240f75 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -8,8 +8,9 @@ import Dodge.Data import Dodge.Config.Data import Dodge.Base.Window import Dodge.Render.Picture -import Dodge.Render.Shape import Dodge.Render.ShapePicture +import Dodge.Render.Walls +import Dodge.Render.Lights import Geometry import Render import Data.Preload.Render @@ -52,7 +53,6 @@ doDrawing pdata w = do -- attempt to poke in parallel let (ws,wp) = worldSPic w MP.bindM3 (\ _ _ _ -> return ()) - --( pokeBindFoldableLayer shadV layerCounts $ worldPictures w ) ( pokeBindFoldableLayer shadV layerCounts wp) ( pokeWallsWindowsFloor (shadVBOptr $ _wallTextureShader pdata) @@ -68,7 +68,6 @@ doDrawing pdata w = do (_eboPtr $ _shapeEBO pdata) (_eboPtr $ _silhouetteEBO pdata) shapeCounts - -- $ worldShape w ws ) nShapeVs <- UMV.read shapeCounts 0 diff --git a/src/Dodge/Render/Lights.hs b/src/Dodge/Render/Lights.hs new file mode 100644 index 000000000..abbdb3ad9 --- /dev/null +++ b/src/Dodge/Render/Lights.hs @@ -0,0 +1,20 @@ +module Dodge.Render.Lights + ( lightsForGloom + ) where +import Dodge.Data +import Geometry + +import Data.Maybe +import qualified Data.IntMap.Lazy as IM + +lightsForGloom :: World -> [(Point3,Float,Point3)] +lightsForGloom w = mapMaybe getLS (IM.elems $ _lightSources w) ++ mapMaybe getTLS (_tempLightSources w) + where + getLS ls + | dist campos (fst2 $ _lsPos ls) > 1000 = Nothing + | otherwise = Just ( _lsPos ls, _lsRad ls^(2::Int) , _lsIntensity ls) + getTLS ls + | dist campos (fst2 $ _tlsPos ls) > 1000 = Nothing + | otherwise = Just ( _tlsPos ls, _tlsRad ls^(2::Int), _tlsIntensity ls) + campos = _cameraCenter w + fst2 (V3 a b _) = V2 a b diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 1a820b8be..cbecea4ea 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -1,58 +1,14 @@ --{-# LANGUAGE TupleSections #-} module Dodge.Render.Picture - ( worldPictures - , wallsAndWindows - , lightsForGloom - , fixedCoordPictures + ( fixedCoordPictures ) where import Dodge.Data ---import Dodge.Update.Camera ---import Dodge.GameRoom -import Dodge.Base import Dodge.Base.Window -import Dodge.Zone -import Dodge.Graph -import Dodge.Picture.SizeInvariant import Dodge.Picture.Layer import Dodge.Render.HUD import Dodge.Render.MenuScreen -import Dodge.Render.ShapePicture -import Dodge.SoundLogic.LoadSound -import Dodge.Config.Data -import Dodge.GameRoom -import Dodge.Update.Camera -import Sound.Data import Geometry import Picture -import ShapePicture - -import Control.Lens -import Data.Maybe -import Data.List (partition) -import qualified Data.IntMap.Lazy as IM -import qualified Data.Map as M - -worldPictures :: World -> Picture -worldPictures w = pictures - [pictures (_decorations w) - ,concatMapPic (_spPicture . dbArg _prDraw) $ _props w - ,concatMapPic (crDraw w) . IM.filter crIsClose $ _creatures w - ,concatMapPic (dbArg _ptDraw) $ _particles w - ,concatMapPic (dbArg _lsPict) $ _lightSources w - ,testPic w - ,concatMapPic (_spPicture . floorItemSPic) $ _floorItems w - ,concatMapPic clDraw $ _clouds w - ,concatMapPic ppDraw $ _pressPlates w - ,concatMapPic btDraw $ _buttons w - ,concatMapPic drawWallFloor $ wallFloorsToDraw w - ,soundPics w - ,viewBoundaries w - ,drawPathing w - ] - where - crIsClose cr = dist (_crPos cr) camCen < winSize - winSize = 30 + max (getWindowX w) (getWindowY w) - camCen = _cameraCenter w fixedCoordPictures :: World -> Picture fixedCoordPictures w = case _menuLayers w of @@ -71,105 +27,3 @@ customMouseCursor w = . color white $ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ] --- TODO remove duplicate! -testPic :: World -> Picture -testPic _ = [] - -drawPathing :: World -> Picture -drawPathing w - | _debug_pathing (_config w) - = -- setLayer 5 $ - (color green . pictures . map (flip thickLine 5 . tflat2) $ graphToEdges gr) - <> concatMap dispInc (graphToIncidence gr) - | otherwise = [] - where - dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n - gr = _pathGraph w -viewBoundaries :: World -> Picture -viewBoundaries w - | _debug_view_boundaries (_config w) - = setLayer 5 $ color green (concatMap (polygonWire . _grBound) grs) - <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w) - | otherwise = [] - where - p = _crPos $ you w - grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w) - -soundPics :: World -> Picture -soundPics w - | _show_sound (_config w) = pictures $ M.map (soundPic w) $ _playingSounds w - | otherwise = [] - -soundPic :: World -> Sound -> Picture -soundPic w s = fixedSizePicClampArrow 50 50 thePic p w - where - p = _soundPos s - thePic - = rotate (_cameraRot w) - . scale theScale theScale - . centerText - . soundToOnomato - $ _soundChunkID s - theScale = 0.15 * f (_soundVolume s * 0.0001) - f x = 1 - 0.5 * (1 - x) - -crDraw :: World -> Creature -> Picture -crDraw w c = _spPicture $ _crPict c c w -ppDraw :: PressPlate -> Picture -ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c) -btDraw :: Button -> Picture -btDraw c = uncurryV translate (_btPos c) $ rotate (_btRot c) (_spPicture $ _btPict c c) - -clDraw :: Cloud -> Picture -clDraw c = translate3 (_clPos c) (_clPict c c) - -wallFloorsToDraw :: World -> [Wall] -wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w - where - onScreen wall = uncurry (lineOnScreen w) $ _wlLine wall - isVisible wl - | 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 _wlOpacity wl == SeeThrough - then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y] - else blank - where - (x,y) = _wlLine wl - c = _wlColor wl - n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x) - -errorNormalizeVDR :: Point2 -> Point2 -errorNormalizeVDR (V2 0 0) = error "problem with function: errorNormalizeVDR in DodgeRendering" -errorNormalizeVDR p = normalizeV p - -wallsAndWindows - :: World - -> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)] ) -wallsAndWindows w - = (map f wls, map f wins) - where - f wl = (_wlLine wl, _wlColor wl) - (wins,wls) = partition theTest . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen w - theTest wl = _wlOpacity wl /= Opaque - -lightsForGloom :: World -> [(Point3,Float,Point3)] -lightsForGloom w = mapMaybe getLS (IM.elems $ _lightSources w) ++ mapMaybe getTLS (_tempLightSources w) - where - getLS ls - | dist campos (fst2 $ _lsPos ls) > 1000 = Nothing - | otherwise = Just ( _lsPos ls, _lsRad ls^(2::Int) , _lsIntensity ls) - getTLS ls - | dist campos (fst2 $ _tlsPos ls) > 1000 = Nothing - | otherwise = Just ( _tlsPos ls, _tlsRad ls^(2::Int), _tlsIntensity ls) - campos = _cameraCenter w - fst2 (V3 a b _) = V2 a b diff --git a/src/Dodge/Render/Shape.hs b/src/Dodge/Render/Shape.hs deleted file mode 100644 index 44b323218..000000000 --- a/src/Dodge/Render/Shape.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Dodge.Render.Shape - ( worldShape - ) where -import Dodge.Data -import Dodge.Base -import Shape -import Geometry ---import Color -import ShapePicture -import Dodge.Base.Window -import Dodge.Render.ShapePicture - -import qualified Data.IntMap as IM -worldShape :: World -> Shape -worldShape w = _foregroundShape w - <> foldMap (crShape w) (IM.filter (pointIsClose . _crPos) (_creatures w)) - <> foldMap (_spShape . floorItemSPic) (IM.filter (pointIsClose . _flItPos) $ _floorItems w) - <> foldMap (_spShape . dbArg _prDraw) (IM.filter (pointIsClose . _pjPos) $ _props w) - <> foldMap btShape (IM.filter (pointIsClose . _btPos) $ _buttons w) - <> foldMap mcShape (IM.filter (pointIsClose . _mcPos) $ _machines w) - where - pointIsClose p = dist camCen p < winSize - winSize = 30 + max (getWindowX w) (getWindowY w) - camCen = _cameraCenter w - -mcShape :: Machine -> Shape -mcShape mc = uncurryV translateSHf (_mcPos mc) $ rotateSH (_mcDir mc) $ _spShape $ _mcDraw mc mc - -btShape :: Button -> Shape -btShape bt = uncurryV translateSHf (_btPos bt) $ rotateSH (_btRot bt) (_spShape $ _btPict bt bt) - -crShape :: World -> Creature -> Shape -crShape w c = _spShape $ _crPict c c w diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index de4a7da49..db7967420 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -1,6 +1,5 @@ module Dodge.Render.ShapePicture - ( floorItemSPic - , worldSPic + ( worldSPic ) where import Dodge.Config.Data @@ -13,14 +12,17 @@ import Dodge.SoundLogic.LoadSound import Dodge.Graph import Dodge.GameRoom import Dodge.Update.Camera +--import Dodge.Zone import Geometry import ShapePicture import Shape import Picture import Sound.Data -import qualified Data.IntMap.Strict as IM +import qualified Data.IntMap.Strict as IM -- Lazy? import qualified Data.Map.Strict as M +--import Control.Lens +--import Data.Maybe worldSPic :: World -> SPic worldSPic w = @@ -106,3 +108,32 @@ viewBoundaries w where p = _crPos $ you w grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w) + +--wallFloorsToDraw :: World -> [Wall] +--wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w +-- where +-- onScreen wall = uncurry (lineOnScreen w) $ _wlLine wall +-- isVisible wl +-- | 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 _wlOpacity wl == SeeThrough +-- then setDepth 0.9 . color c $ polygon [x,x +.+ n2,y+.+n2, y] +-- else blank +-- where +-- (x,y) = _wlLine wl +-- c = _wlColor wl +-- n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x) +-- +--errorNormalizeVDR :: Point2 -> Point2 +--errorNormalizeVDR (V2 0 0) = error "problem with function: errorNormalizeVDR in DodgeRendering" +--errorNormalizeVDR p = normalizeV p diff --git a/src/Dodge/Render/Walls.hs b/src/Dodge/Render/Walls.hs new file mode 100644 index 000000000..ebed6cfda --- /dev/null +++ b/src/Dodge/Render/Walls.hs @@ -0,0 +1,19 @@ +module Dodge.Render.Walls + ( wallsAndWindows + ) where +import Dodge.Data +import Dodge.Zone +import Geometry + +import Data.List +import qualified Data.IntMap.Strict as IM +wallsAndWindows + :: World + -> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)] ) +wallsAndWindows w + = (map f wls, map f wins) + where + f wl = (_wlLine wl, _wlColor wl) + (wins,wls) = partition theTest . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen w + theTest wl = _wlOpacity wl /= Opaque +