Make pictures use Streaming

src/Dodge/Creature/Lamp.hs

@@ -16,6 +16,8 @@ import Polyhedra
 import qualified IntMapHelp as IM
 import LensHelp
 
+import qualified Streaming.Prelude as S
+
 colorLamp 
     :: Point3   -- color of lamp
     -> Float    -- height of lamp
@@ -39,7 +41,7 @@ lamp h = defaultInanimate
 lampCrPic :: Float -> Picture
 lampCrPic h = pictures 
     [ setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
-    , concatMap (polyToTris . map f) $ boxXYZnobase 5 5 (h-1)
+    , foldMap (S.each . polyToTris . map f) $ boxXYZnobase 5 5 (h-1)
     ]
   where
     f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] BottomLayer polyNum

src/Dodge/Render/HUD.hs

@@ -235,7 +235,7 @@ combineCounts cfig w = winScale cfig . foldMap f . group
 
 lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture
 lnkMidPosInvSelsCol cfig w i col = winScale cfig 
-    . concatMap (\j -> zConnectCol rp (V2 18 0+selNumMidHeight cfig w j) col white white (selNumCol j w))
+    . foldMap (\j -> zConnectCol rp (V2 18 0+selNumMidHeight cfig w j) col white white (selNumCol j w))
   where
 --    lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5))
     rp = V2 (190 - hw) ( hh - (20 * fromIntegral i + 77.5))

src/Dodge/Render/List.hs

@@ -6,6 +6,7 @@ import Picture
 import Geometry
 --import Control.Monad
 import Data.Maybe
+import Data.Foldable
 
 -- given a list of pictures that are each the size of a "text" call, displays them as
 -- a list on the screen
@@ -30,7 +31,7 @@ listCursorChooseBorder borders xoff yoff cfig yint col cursxsize cursysize = win
     hgt = 20 * fromIntegral cursysize
 -- note we cannot simply scale lines because they are drawn as solid rectangles
 chooseCursorBorders :: Float -> Float -> [Bool] -> Picture
-chooseCursorBorders wth hgt = concat . catMaybes . zipWith f
+chooseCursorBorders wth hgt = fold . catMaybes . zipWith f
     [ line [V2   0 hgt , V2 wth hgt ] 
     , line [V2 wth hgt , V2 wth   0 ] 
     , line [V2 wth   0 , V2   0   0 ]

src/Dodge/Render/ShapePicture.hs

@@ -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' (dbArg _prDraw) (filtOn _prPos _props)
-    <> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
+    <> foldMap' (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
-    <> foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)
+    <> foldMap' (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)
-    <> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
+    <> foldMap' (dbArg _cpPict) (filtOn _cpPos _corpses)
-    <> foldMap (dbArg _crPict) (filtOn _crPos _creatures)
+    <> foldMap' (dbArg _crPict) (filtOn _crPos _creatures)
-    <> foldMap floorItemSPic (filtOn _flItPos _floorItems)
+    <> foldMap' floorItemSPic (filtOn _flItPos _floorItems)
-    <> foldMap btSPic (filtOn _btPos _buttons)
+    <> foldMap' btSPic (filtOn _btPos _buttons)
-    <> foldMap mcSPic (filtOn _mcPos _machines)
+    <> 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)
+viewBoundaries w = setLayer DebugLayer $ color green (foldMap (polygonWire . _grBound) grs)
-    <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
+    <> 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

src/Picture/Base.hs

@@ -47,9 +47,12 @@ import Geometry
 import Picture.Data
 import Color
 
+import qualified Streaming.Prelude as S
+import Data.Foldable
+
 blank :: Picture
 {-# INLINE blank #-}
-blank = []
+blank = mempty
 
 polygonWire :: [Point2] -> Picture
 {-# INLINE polygonWire #-}
@@ -58,19 +61,19 @@ polygonWire ps = line (ps ++ [head ps])
 -- | Expects clockwise input.
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
-polygon = map f . polyToTris
+polygon = S.each . map f . polyToTris
   where
     f (V2 x y) = Verx (V3 x y 0) black [] BottomLayer polyNum
 
 polygonZ :: [Point2] -> Float -> Picture
 {-# INLINE polygonZ #-}
-polygonZ ps z = map (f . zeroZ) $ polyToTris ps
+polygonZ ps z = S.each . map (f . zeroZ) $ polyToTris ps
   where
     f pos = Verx pos black [z] BottomLayer polyzNum
 
 polygonCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE polygonCol #-}
-polygonCol = polyToTris . map f
+polygonCol = S.each . polyToTris . map f
   where
     f (V2 x y,col) = Verx (V3 x y 0) col [] BottomLayer polyNum
 
@@ -80,7 +83,7 @@ poly3 = poly3Col . map (, black)
 
 poly3Col :: [(Point3,RGBA)] -> Picture
 {-# INLINE poly3Col #-}
-poly3Col = map f . polyToTris
+poly3Col = S.each . map f . polyToTris
   where
     f (pos,col) = Verx pos col [] BottomLayer polyNum
 
@@ -119,7 +122,7 @@ bezierQuad cola colc ra rc a b c
     fc' = extrapolate cIn aIn bIn
 
 bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
-bzhelp = map f
+bzhelp = S.each . map f
   where
     f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col [a,b,c,d] BottomLayer bezNum
 
@@ -140,7 +143,7 @@ extrapolate (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 x y) =
 
 color :: RGBA -> Picture -> Picture
 {-# INLINE color #-}
-color c = map $ overCol (const c)
+color c = S.map $ overCol (const c)
 
 translateH :: Float -> Float -> Point3 -> Point3
 {-# INLINE translateH #-}
@@ -148,30 +151,30 @@ translateH !a !b (V3 x y z) = V3 (x+a) (y+b) z
 
 translate :: Float -> Float -> Picture -> Picture
 {-# INLINE translate #-}
-translate x = map . overPos . translateH x
+translate x = S.map . overPos . translateH x
 
 translate3 :: Point3 -> Picture -> Picture
 {-# INLINE translate3 #-}
-translate3 = map . overPos . (+.+.+)
+translate3 = S.map . overPos . (+.+.+)
 
 tranRot :: V2 Float -> Float -> Picture -> Picture
 {-# INLINE tranRot #-}
-tranRot (V2 x y) r = map $ overPos (translateH x y . rotate3 r)
+tranRot (V2 x y) r = S.map $ overPos (translateH x y . rotate3 r)
 
 setDepth :: Float -> Picture -> Picture
 {-# INLINE setDepth #-}
 --setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
-setDepth d = map $ overPos (\(V3 x y _) -> V3 x y d)
+setDepth d = S.map $ overPos (\(V3 x y _) -> V3 x y d)
 
 addDepth :: Float -> Picture -> Picture
 {-# INLINE addDepth #-}
 --addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
-addDepth d = map $ overPos (\(V3 x y z) -> V3 x y (z+d))
+addDepth d = S.map $ overPos (\(V3 x y z) -> V3 x y (z+d))
 
 -- TODO change the Int here to a dedicated type
 setLayer :: Layer -> Picture -> Picture
 {-# INLINE setLayer #-}
-setLayer i = map f
+setLayer i = S.map f
   where
     f v = v {_vxLayer = i}
 
@@ -181,23 +184,23 @@ scale3 a b (V3 x y z) = V3 (x*a) (y*b) z
 
 scale :: Float -> Float -> Picture -> Picture
 {-# INLINE scale #-}
-scale x = map . overPos . scale3 x
+scale x = S.map . overPos . scale3 x
 
 rotate :: Float -> Picture -> Picture
 {-# INLINE rotate #-}
-rotate = map . overPos . rotate3
+rotate = S.map . overPos . rotate3
 
 concatMapPic :: Foldable t => (a -> Picture) -> t a -> Picture
 {-# INLINE concatMapPic #-}
-concatMapPic = concatMap
+concatMapPic = foldMap
 
 appendPic :: Picture -> Picture -> Picture
 {-# INLINE appendPic #-}
-appendPic = (++)
+appendPic = (<>)
 
 pictures :: Foldable t => t Picture -> Picture
 {-# INLINABLE pictures #-}
-pictures = concat
+pictures = fold
 
 makeArc :: Float -> Point2 -> [Point2]
 {-# INLINE makeArc #-}
@@ -212,7 +215,7 @@ circleSolid = circleSolidCol white white
 
 circleSolidCol :: Color -> Color -> Float -> Picture
 {-# INLINE circleSolidCol #-}
-circleSolidCol colC colE r = map f
+circleSolidCol colC colE r = S.each $ map f
     [(V3 (-r)   r  0, colC)
     ,(V3 (-r) (-r) 0, colE)
     ,(V3   r  (-r) 0, black)
@@ -234,7 +237,7 @@ stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0,100..]
 
 text :: String -> Picture
 {-# INLINE text #-}
-text = map f . stringToList
+text = S.each . map f . stringToList
   where
     f (pos,col,V2 a b) = Verx pos col [a,b] BottomLayer textNum
 
@@ -316,7 +319,7 @@ thickArc startA endA rad wdth
 
 thickArcHelp :: Float -> Float -> Float -> Float -> Picture
 {-# INLINE thickArcHelp #-}
-thickArcHelp startA endA rad wdth = map f
+thickArcHelp startA endA rad wdth = S.each $ map f
     [  (V3 0 0 0,black,V3 0 0 wdth)
     ,(V3 xa ya 0,black,V3 1 0 wdth)
     ,(V3 xb yb 0,black,V3 1 1 wdth)
@@ -363,11 +366,11 @@ charToTuple x c =
     offset = fromIntegral (fromEnum c) - 32
 
 mirrorxz :: Picture -> Picture
-mirrorxz = map (overPos flipy)
+mirrorxz = S.map (overPos flipy)
   where
     flipy (V3 x y z) = V3 x (negate y) z
 
 mirroryz :: Picture -> Picture
-mirroryz = map (overPos flipx)
+mirroryz = S.map (overPos flipx)
   where
     flipx (V3 x y z) = V3 (negate x) y z

src/Picture/Data.hs

@@ -6,6 +6,7 @@ import Geometry.Data
 
 --import qualified Data.Vector.Fusion.Stream.Monadic as VS
 import Control.Lens
+import Streaming
 data Verx = Verx
     { _vxPos    :: !Point3
     , _vxCol    :: !Point4
@@ -45,7 +46,7 @@ bezNum      = ShadNum 2
 textNum     = ShadNum 3
 arcNum      = ShadNum 4
 ellNum      = ShadNum 5
-type Picture = [Verx]
+type Picture = Stream (Of Verx) IO ()
 flat2 :: V2 a -> [a]
 flat2 (V2 x y) = [x,y]
 flat3 :: V3 a -> [a]

src/Polyhedra.hs

@@ -18,6 +18,7 @@ import Data.Maybe
 import Data.List
 import Data.Bifunctor
 import Control.Lens
+import qualified Streaming.Prelude as S
 
 translateXY :: Float -> Float -> Polyhedra -> Polyhedra
 translateXY x y = pyFaces %~ map (map $ first tran)
@@ -119,7 +120,7 @@ polyToPics :: Polyhedra -> [Picture]
 polyToPics = map helpPoly3D . _pyFaces
 
 helpPoly3D :: [(Point3, Point4)] -> Picture
-helpPoly3D = map f . polyToTris
+helpPoly3D = S.each . map f . polyToTris
   where
     f (pos,col) = Verx pos col [] BottomLayer polyNum
 

src/Shader/Poke.hs

@@ -30,7 +30,7 @@ pokeVerxs
     -> UMV.MVector (PrimState IO) Int 
     -> Picture 
     -> IO ()
-pokeVerxs vbos count = VS.mapM_ (pokeVerx vbos count) . VS.fromList
+pokeVerxs vbos count = S.mapM_ (pokeVerx vbos count)
 
 pokeVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
 pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=theShadNum} = do
@@ -86,7 +86,6 @@ pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort
     -> IO (Int,Int,Int)
 pokeShape ptr iptr ieptr = S.foldM_ (pokeShapeObj ptr iptr ieptr) (return (0,0,0)) return
 
-
 pokeShapeObj
     :: Ptr Float 
     -> Ptr GLushort 
@@ -187,7 +186,7 @@ pokeLayVerxs
     -> UMV.MVector (PrimState IO) Int
     -> Picture 
     -> IO ()
-pokeLayVerxs vbos counts = VS.mapM_ (pokeLayVerx vbos counts) . VS.fromList
+pokeLayVerxs vbos counts = S.mapM_ (pokeLayVerx vbos counts)
 
 pokeLayVerx :: MV.MVector (PrimState IO) FullShader -> UMV.MVector (PrimState IO) Int -> Verx -> IO ()
 --{-# INLINE pokeLayVerx #-}