Make pictures use Streaming

2022-07-03 23:55:21 +01:00
parent f9a904d52b
commit 7fa391eb6c
8 changed files with 54 additions and 46 deletions
@@ -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
@@ -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))
@@ -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 ]
@@ -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
@@ -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
@@ -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]
@@ -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

@@ -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
@@ -85,7 +85,6 @@ pokeShape :: Ptr Float -> Ptr GLushort -> Ptr GLushort
    -> Stream (Of ShapeObj) IO ()
    -> IO (Int,Int,Int)
 pokeShape ptr iptr ieptr = S.foldM_ (pokeShapeObj ptr iptr ieptr) (return (0,0,0)) return
-    

 pokeShapeObj
    :: Ptr Float 
@@ -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 #-}