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

Remove some Streaming

Browse Source
This commit is contained in:
justin
2022-08-21 21:53:40 +01:00
parent f1ef75f511
commit cccab45650
8 changed files with 92 additions and 85 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Bound.hs
+18 -15
View File
@@ -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
src/Color.hs
-1
View File
@@ -2,7 +2,6 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Color where
src/Dodge/Render/ShapePicture.hs
+2 -1
View File
@@ -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
+4 -4
View File
@@ -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
src/Dodge/Update/Camera.hs
+12 -20
View File
@@ -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 =
src/Grid.hs
+54 -42
View File
@@ -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))
]
src/LinearHelp.hs
+1 -1
View File
@@ -1,5 +1,5 @@
--{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
--{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StandaloneDeriving #-}
src/Quaternion.hs
+1 -1
View File
@@ -1,7 +1,7 @@
{-# LANGUAGE DeriveAnyClass #-}
--{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
--{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}