Reorganise render collections

2021-11-01 02:15:22 +00:00
parent da346bc3a0
commit 7692421112
6 changed files with 76 additions and 186 deletions
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
+