Remove some Streaming

src/Bound.hs

@@ -1,19 +1,22 @@
-module Bound where
+module Bound (
+    boundPoints,
+) where
+
+import qualified Control.Foldl as L
+import Control.Lens
 import Geometry
 
-import Control.Lens
+---- NSEW
-import Streaming
+boundPoints :: [Point2] -> Maybe (Float, Float, Float, Float)
-import qualified Streaming.Prelude as S
-import qualified Control.Foldl as L
-
--- NSEW
-boundPoints :: Stream (Of Point2) Identity () -> Maybe (Float,Float,Float,Float)
 {-# INLINE boundPoints #-}
-boundPoints = f . runIdentity . L.purely S.fold_ ((,,,) 
+boundPoints =
-    <$> L.premap (^?! _2) L.maximum
+    f
-    <*> L.premap (^?! _2) L.minimum
+        . L.fold
-    <*> L.premap (^?! _1) L.maximum
+            ( (,,,)
-    <*> L.premap (^?! _1) L.minimum
+                <$> L.premap (^?! _2) L.maximum
-    )
+                <*> L.premap (^?! _2) L.minimum
+                <*> L.premap (^?! _1) L.maximum
+                <*> L.premap (^?! _1) L.minimum
+            )
   where
-    f (mn,ms,me,mw) = (,,,) <$> mn <*> ms <*> me <*> mw
+    f (mn, ms, me, mw) = (,,,) <$> mn <*> ms <*> me <*> mw

src/Color.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE StrictData #-}
-{-# LANGUAGE TemplateHaskell #-}
 
 module Color where
 

src/Dodge/Render/ShapePicture.hs

@@ -275,7 +275,8 @@ drawFarWallDetect w =
                     , fst $ collidePoint p q $ filter wlIsOpaque $ wlsNearSeg p q w
                     ]
             )
-        $ runIdentity $ S.toList_ $ streamViewpoints p w
+        $ getViewpoints p w
+        -- $ runIdentity $ S.toList_ $ streamViewpoints p w
   where
     p = w ^. cWorld . cwCam . cwcViewFrom
 

src/Dodge/Room/Foreground.hs

@@ -21,8 +21,6 @@ import Picture
 import Quaternion
 import Shape
 import ShapePicture
-import Streaming
-import qualified Streaming.Prelude as S
 
 highMesh ::
     Point2 ->
@@ -143,8 +141,10 @@ putShape sh =
     bnds = shapeBounds sh
     m = midBounds bnds
 
-shapePoints :: Shape -> Stream (Of Point2) Identity ()
+--shapePoints :: Shape -> Stream (Of Point2) Identity ()
-shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
+--shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs)
+shapePoints :: Shape -> [Point2]
+shapePoints = concatMap (map (stripZ . _svPos) . _shVs)
 
 shapeBounds :: Shape -> (Float, Float, Float, Float)
 shapeBounds = fromMaybe (0, 0, 0, 0) . boundPoints . shapePoints

src/Dodge/Update/Camera.hs

@@ -4,8 +4,9 @@ and the position that the character sees from: '_cameraViewFrom'.  -}
 module Dodge.Update.Camera (
     updateCamera,
     farWallPoints,
-    streamViewpoints,
+    --    streamViewpoints,
     farWallDistDirection,
+    getViewpoints,
 ) where
 
 import Bound
@@ -24,11 +25,6 @@ import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
 import qualified SDL
---import Data.Monoid
---import Data.Semigroup
-
-import Streaming
-import qualified Streaming.Prelude as S
 
 {- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers;
 update where your avatar's view is from.  -}
@@ -65,7 +61,6 @@ moveZoomCamera uv =
         yourItem w ^? _Just . itScope . scopePos
     newcen = cpos +.+ fromMaybe (V2 0 0) mscopeoffset +.+ offset
     offset = rotateV (w ^. cWorld . cwCam . cwcRot) $ ((newzoom - newDefaultZoom) / (newDefaultZoom * newzoom)) *.* _mousePos w
-    --newzoom = changeZoom (_cameraZoom w) idealZoom'
     newzoom = case yourItem w ^? _Just . itScope of
         Just zs@ZoomScope{} -> _scopeZoom zs
         _ -> newDefaultZoom * newItemZoom
@@ -81,7 +76,6 @@ moveZoomCamera uv =
         | curZoom > idealZoom + 0.01 = ((zoomOutSpeed -1) * curZoom + idealZoom) / zoomOutSpeed
         | curZoom < idealZoom - 0.01 = ((zoomInSpeed -1) * curZoom + idealZoom) / zoomInSpeed
         | otherwise = idealZoom
-    --wallZoom = farWallDist newvf cfig w
     wallZoom = min4 (w ^. cWorld . cwCam . cwcBoundDist)
     min4 (a, b, c, d) = minimum [hh / maxd a, hh / maxd (- b), hw / maxd c, hw / maxd (- d)]
     maxd = max distFromEqmnt
@@ -224,18 +218,17 @@ setViewDistance cfig w =
     w & cWorld . cwCam . cwcViewDistance
         .~ sqrt (halfWidth cfig ** 2 + halfHeight cfig ** 2) / (w ^. cWorld . cwCam . cwcZoom)
 
---    .~ max (halfWidth cfig) (halfHeight cfig) / _cameraZoom w
+getViewpoints :: Point2 -> World -> [Point2]
+{-# INLINE getViewpoints #-}
+getViewpoints p w =
+    concatMap (gameRoomViewpoints p) $
+        filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen (_cWorld w))
 
-streamViewpoints :: Monad m => Point2 -> World -> Stream (Of Point2) m ()
+gameRoomViewpoints :: Point2 -> GameRoom -> [Point2]
-{-# INLINE streamViewpoints #-}
+{-# INLINE gameRoomViewpoints #-}
-streamViewpoints p w =
-    flip S.for (gameRoomViewpoints p) $
-        S.filter (pointInOrOnPolygon p . _grBound) $ S.each (_cwgGameRooms $ _cwGen (_cWorld w))
-
-gameRoomViewpoints :: Monad m => Point2 -> GameRoom -> Stream (Of Point2) m ()
 gameRoomViewpoints p gr =
-    S.each (_grViewpoints gr)
+    (_grViewpoints gr)
-        <> S.map extend (S.each (_grViewpointsEx gr) <> S.map addDir (S.each $ _grLinkDirs gr))
+        <> map extend ((_grViewpointsEx gr) <> map addDir (_grLinkDirs gr))
   where
     extend outp = p +.+ maxViewDistance *.* squashNormalizeV (outp -.- p)
     addDir a = p +.+ unitVectorAtAngle a
@@ -243,12 +236,11 @@ gameRoomViewpoints p gr =
 farWallDistDirection :: Point2 -> World -> Maybe (Float, Float, Float, Float)
 farWallDistDirection p w =
     boundPoints $
-        S.map f vps
+        map f $ getViewpoints p w
   where
     f q = (rotateV (negate (w ^. cWorld . cwCam . cwcRot)) . (-.- p)) (foldl' findPoint q (wls q))
     wls q = filter wlIsOpaque $ wlsNearSeg p q w
     findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine
-    vps = streamViewpoints p w
 
 extendedViewPoints :: Point2 -> [GameRoom] -> [Point2]
 extendedViewPoints p grs =

src/Grid.hs

@@ -1,32 +1,37 @@
 module Grid where
-import Geometry
-import Bound
 
+import Bound
 --import Data.Function (on)
-import Data.List
+
 import Data.Bifunctor
+import Data.List
 --import Data.Maybe
 import qualified Data.Tuple.Extra as Tup
-import qualified Streaming.Prelude as S
+import Geometry
---import qualified Control.Foldl as L
---import qualified Data.Set as S
 
 gridInPolygon :: Float -> [Point2] -> [Point2]
-gridInPolygon gap ps = filter (`pointInPolygon` ps)
+gridInPolygon gap ps =
-    .  maybe [] (boundedGrid gap) . boundPoints . S.each $ ps
+    filter (`pointInPolygon` ps)
+        . maybe [] (boundedGrid gap)
+        . boundPoints
+        $ ps
 
-boundedGrid :: Float -> (Float,Float,Float,Float) -> [Point2]
+boundedGrid :: Float -> (Float, Float, Float, Float) -> [Point2]
-boundedGrid gap (n,s,e,w) = gridPointsOff w s gap nx gap ny
+boundedGrid gap (n, s, e, w) = gridPointsOff w s gap nx gap ny
   where
-    nx = floor $ (e-w) / gap
+    nx = floor $ (e - w) / gap
-    ny = floor $ (n-s) / gap
+    ny = floor $ (n - s) / gap
 
-shiftedGrid
+shiftedGrid ::
-    :: Float    -- ^ x min
+    -- | x min
-    -> Float    -- ^ x max
+    Float ->
-    -> Float    -- ^ y min
+    -- | x max
-    -> Float    -- ^ y max
+    Float ->
-    -> [(Point2,Point2)]
+    -- | y min
+    Float ->
+    -- | y max
+    Float ->
+    [(Point2, Point2)]
 shiftedGrid xmin xmax ymin ymax = grid
   where
     xd = xmax - xmin
@@ -34,45 +39,52 @@ shiftedGrid xmin xmax ymin ymax = grid
     xsteps = ceiling $ (xd - 40) / 60
     ysteps = ceiling $ (yd - 40) / 60
     shift p = bimap (p +.+) (p +.+)
-    grid = map (shift (V2 (xmin + 20) (ymin+20))) $ makeGrid 60 xsteps 60 ysteps
+    grid = map (shift (V2 (xmin + 20) (ymin + 20))) $ makeGrid 60 xsteps 60 ysteps
 
 -- creates a rectangular grid starting at (0,0) in the positive orthant
 -- needs fixing in degenerate (xstep or ystep == 0) cases
-makeGrid 
+makeGrid ::
-    :: Float    -- ^ horizontal step size
+    -- | horizontal step size
-    -> Int      -- ^ number of horizontal steps
+    Float ->
-    -> Float    -- ^ vertical step size
+    -- | number of horizontal steps
-    -> Int      -- ^ number of vertical steps
+    Int ->
-    -> [(Point2,Point2)]
+    -- | vertical step size
-makeGrid x nx y ny 
+    Float ->
-    = nub 
+    -- | number of vertical steps
-    . concatMap doublePair 
+    Int ->
-    . concatMap (\p -> map (Tup.both (p +.+)) $ makeRect x y)
+    [(Point2, Point2)]
-    $ gridPoints x nx y ny
+makeGrid x nx y ny =
+    nub
+        . concatMap doublePair
+        . concatMap (\p -> map (Tup.both (p +.+)) $ makeRect x y)
+        $ gridPoints x nx y ny
 
 gridPointsOff :: Float -> Float -> Float -> Int -> Float -> Int -> [Point2]
 gridPointsOff xoff yoff x nx y ny = map f $ gridPoints' nx ny
   where
-    f (a,b) = V2 (xoff + fromIntegral a * x) (yoff + fromIntegral b * y)
+    f (a, b) = V2 (xoff + fromIntegral a * x) (yoff + fromIntegral b * y)
 
 gridPoints :: Float -> Int -> Float -> Int -> [Point2]
 gridPoints = gridPointsOff 0 0
+
 --    map f $ gridPoints' nx ny
 --  where
 --    f (a,b) = V2 (fromIntegral a * x) (fromIntegral b * y)
 
-gridPoints'' :: Float -> Int -> Float -> Int -> [(Point2,(Int,Int))]
+gridPoints'' :: Float -> Int -> Float -> Int -> [(Point2, (Int, Int))]
 gridPoints'' x nx y ny = map f $ gridPoints' nx ny
   where
-    f (a,b) = (V2 (fromIntegral a * x) (fromIntegral b * y), (a,b))
+    f (a, b) = (V2 (fromIntegral a * x) (fromIntegral b * y), (a, b))
 
-gridPoints' :: Int -> Int -> [(Int,Int)]
+gridPoints' :: Int -> Int -> [(Int, Int)]
-gridPoints' nx ny = [(x,y) | x <- [0..nx-1], y <- [0..ny-1]]
+gridPoints' nx ny = [(x, y) | x <- [0 .. nx -1], y <- [0 .. ny -1]]
 
-makeRect :: Float -> Float -> [(Point2,Point2)]
+makeRect :: Float -> Float -> [(Point2, Point2)]
-makeRect x y = map (bimap toV2 toV2) 
+makeRect x y =
-    [((0,0),(x,0))
+    map
-    ,((0,0),(0,y))
+        (bimap toV2 toV2)
-    ,((x,y),(x,0))
+        [ ((0, 0), (x, 0))
-    ,((x,y),(0,y))
+        , ((0, 0), (0, y))
-    ]
+        , ((x, y), (x, 0))
+        , ((x, y), (0, y))
+        ]

src/LinearHelp.hs

@@ -1,5 +1,5 @@
 --{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TemplateHaskell #-}
+--{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE StandaloneDeriving #-}

src/Quaternion.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 --{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TemplateHaskell #-}
+--{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}