From cccab45650e017d9d7e629e38fd49fa9e90aca86 Mon Sep 17 00:00:00 2001 From: justin Date: Sun, 21 Aug 2022 21:53:40 +0100 Subject: [PATCH] Remove some Streaming --- src/Bound.hs | 33 ++++++----- src/Color.hs | 1 - src/Dodge/Render/ShapePicture.hs | 3 +- src/Dodge/Room/Foreground.hs | 8 +-- src/Dodge/Update/Camera.hs | 32 ++++------- src/Grid.hs | 96 ++++++++++++++++++-------------- src/LinearHelp.hs | 2 +- src/Quaternion.hs | 2 +- 8 files changed, 92 insertions(+), 85 deletions(-) diff --git a/src/Bound.hs b/src/Bound.hs index 9a9ad8e29..05ff9ebe6 100644 --- a/src/Bound.hs +++ b/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 -import Streaming -import qualified Streaming.Prelude as S -import qualified Control.Foldl as L - --- NSEW -boundPoints :: Stream (Of Point2) Identity () -> Maybe (Float,Float,Float,Float) +---- NSEW +boundPoints :: [Point2] -> Maybe (Float, Float, Float, Float) {-# INLINE boundPoints #-} -boundPoints = f . runIdentity . L.purely S.fold_ ((,,,) - <$> L.premap (^?! _2) L.maximum - <*> L.premap (^?! _2) L.minimum - <*> L.premap (^?! _1) L.maximum - <*> L.premap (^?! _1) L.minimum - ) +boundPoints = + f + . L.fold + ( (,,,) + <$> 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 diff --git a/src/Color.hs b/src/Color.hs index ca5c2d659..a8332fddd 100644 --- a/src/Color.hs +++ b/src/Color.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} module Color where diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index fe6a2a76a..c9b4b7f37 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/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 diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 2d9ffdba1..254c736f4 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/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 = S.each . concatMap (map (stripZ . _svPos) . _shVs) +--shapePoints :: Shape -> Stream (Of Point2) Identity () +--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 diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 40a6eed6c..cc762d1d4 100644 --- a/src/Dodge/Update/Camera.hs +++ b/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 () -{-# INLINE streamViewpoints #-} -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 :: Point2 -> GameRoom -> [Point2] +{-# INLINE gameRoomViewpoints #-} gameRoomViewpoints p gr = - S.each (_grViewpoints gr) - <> S.map extend (S.each (_grViewpointsEx gr) <> S.map addDir (S.each $ _grLinkDirs gr)) + (_grViewpoints 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 = diff --git a/src/Grid.hs b/src/Grid.hs index 7f6daed1b..76a8f0bd3 100644 --- a/src/Grid.hs +++ b/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 qualified Control.Foldl as L ---import qualified Data.Set as S +import Geometry gridInPolygon :: Float -> [Point2] -> [Point2] -gridInPolygon gap ps = filter (`pointInPolygon` ps) - . maybe [] (boundedGrid gap) . boundPoints . S.each $ ps +gridInPolygon gap ps = + filter (`pointInPolygon` ps) + . maybe [] (boundedGrid gap) + . boundPoints + $ ps -boundedGrid :: Float -> (Float,Float,Float,Float) -> [Point2] -boundedGrid gap (n,s,e,w) = gridPointsOff w s gap nx gap ny +boundedGrid :: Float -> (Float, Float, Float, Float) -> [Point2] +boundedGrid gap (n, s, e, w) = gridPointsOff w s gap nx gap ny where - nx = floor $ (e-w) / gap - ny = floor $ (n-s) / gap + nx = floor $ (e - w) / gap + ny = floor $ (n - s) / gap -shiftedGrid - :: Float -- ^ x min - -> Float -- ^ x max - -> Float -- ^ y min - -> Float -- ^ y max - -> [(Point2,Point2)] +shiftedGrid :: + -- | x min + Float -> + -- | x max + Float -> + -- | 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 - :: Float -- ^ horizontal step size - -> Int -- ^ number of horizontal steps - -> Float -- ^ vertical step size - -> Int -- ^ number of vertical steps - -> [(Point2,Point2)] -makeGrid x nx y ny - = nub - . concatMap doublePair - . concatMap (\p -> map (Tup.both (p +.+)) $ makeRect x y) - $ gridPoints x nx y ny +makeGrid :: + -- | horizontal step size + Float -> + -- | number of horizontal steps + Int -> + -- | vertical step size + Float -> + -- | number of vertical steps + Int -> + [(Point2, Point2)] +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' nx ny = [(x,y) | x <- [0..nx-1], y <- [0..ny-1]] +gridPoints' :: Int -> Int -> [(Int, Int)] +gridPoints' nx ny = [(x, y) | x <- [0 .. nx -1], y <- [0 .. ny -1]] -makeRect :: Float -> Float -> [(Point2,Point2)] -makeRect x y = map (bimap toV2 toV2) - [((0,0),(x,0)) - ,((0,0),(0,y)) - ,((x,y),(x,0)) - ,((x,y),(0,y)) - ] +makeRect :: Float -> Float -> [(Point2, Point2)] +makeRect x y = + map + (bimap toV2 toV2) + [ ((0, 0), (x, 0)) + , ((0, 0), (0, y)) + , ((x, y), (x, 0)) + , ((x, y), (0, y)) + ] diff --git a/src/LinearHelp.hs b/src/LinearHelp.hs index 989b3d6da..12f1fab6b 100644 --- a/src/LinearHelp.hs +++ b/src/LinearHelp.hs @@ -1,5 +1,5 @@ --{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} +--{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE StandaloneDeriving #-} diff --git a/src/Quaternion.hs b/src/Quaternion.hs index 64ba0faaf..c5d5fdcb6 100644 --- a/src/Quaternion.hs +++ b/src/Quaternion.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} --{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +--{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-}