justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Make pictures use Streaming

Browse Source
This commit is contained in:
justin
2022-07-03 23:55:21 +01:00
parent f9a904d52b
commit 7fa391eb6c
8 changed files with 54 additions and 46 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Render/ShapePicture.hs
+16 -15
View File
@@ -38,18 +38,19 @@ import qualified Streaming.Prelude as S
import qualified Data.Graph.Inductive as FGL
import qualified Data.Set as Set
import Padding
import Data.Foldable
-- TODO only filter out shapes outside the range of the furthest shown light source
worldSPic :: Configuration -> World -> SPic
worldSPic cfig w = (mempty, extraPics cfig w)
<> foldMap (dbArg _prDraw) (filtOn _prPos _props)
<> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
<> foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)
<> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
<> foldMap (dbArg _crPict) (filtOn _crPos _creatures)
<> foldMap floorItemSPic (filtOn _flItPos _floorItems)
<> foldMap btSPic (filtOn _btPos _buttons)
<> foldMap mcSPic (filtOn _mcPos _machines)
<> foldMap' (dbArg _prDraw) (filtOn _prPos _props)
<> foldMap' (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
<> foldMap' (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)
<> foldMap' (dbArg _cpPict) (filtOn _cpPos _corpses)
<> foldMap' (dbArg _crPict) (filtOn _crPos _creatures)
<> foldMap' floorItemSPic (filtOn _flItPos _floorItems)
<> foldMap' btSPic (filtOn _btPos _buttons)
<> foldMap' mcSPic (filtOn _mcPos _machines)
<> anyTargeting cfig w
where
filtOn f g = IM.filter (pointIsClose . f) (g w)
@@ -81,7 +82,7 @@ extraPics cfig w = pictures (_decorations w)
<> concatMapPic clDraw (_clouds w )
<> concatMapPic ppDraw (_pressPlates w )
<> viewClipBounds cfig w
<> debugDraw cfig w
-- <> debugDraw cfig w
debugDraw :: Configuration -> World -> Picture
{-# INLINE debugDraw #-}
@@ -187,7 +188,7 @@ drawWorldSelect w = setLayer DebugLayer
drawFarWallDetect :: World -> Picture
drawFarWallDetect w = setLayer DebugLayer
. color yellow
. concatMap (\q -> line
. foldMap (\q -> line
[ p
, fst $ collidePoint p q $ S.filter wlIsOpaque $ wlsNearSeg p q w
] )
@@ -305,7 +306,7 @@ edgeToPic poly pe
drawPathing :: Configuration -> World -> Picture
drawPathing cfig w = setLayer DebugLayer
$ foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr)
<> concatMap dispInc (graphToIncidence gr)
<> foldMap dispInc (graphToIncidence gr)
where
dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
gr = _pathGraph w
@@ -340,8 +341,8 @@ drawCrInfo cfig w = setLayer FixedCoordLayer
hw = halfWidth cfig
viewBoundaries :: World -> Picture
viewBoundaries w = setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs)
<> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
viewBoundaries w = setLayer DebugLayer $ color green (foldMap (polygonWire . _grBound) grs)
<> color yellow (foldMap (\q -> line [p,q]) $ farWallPoints p w)
where
p = _crPos $ you w
grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
@@ -349,10 +350,10 @@ viewBoundaries w = setLayer DebugLayer $ color green (concatMap (polygonWire . _
viewClipBounds :: Configuration -> World -> Picture
viewClipBounds cfig w
| _debug_view_clip_bounds cfig == AllRoomClipBoundaries
= setLayer DebugLayer $ color green $ concatMap (polygonWire . _cpPoints) (_roomClipping w)
= setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_roomClipping w)
| _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries
= setLayer DebugLayer $ f (_roomClipping w)
| otherwise = []
| otherwise = mempty
where
f (x:xs) = g x xs <> f xs
f [] = mempty