diff --git a/src/Bound.hs b/src/Bound.hs index 9462e284d..708020eea 100644 --- a/src/Bound.hs +++ b/src/Bound.hs @@ -7,6 +7,7 @@ import qualified Streaming.Prelude as S import qualified Control.Foldl as L boundPoints :: Stream (Of Point2) Identity () -> Maybe (Float,Float,Float,Float) +{-# INLINE boundPoints #-} boundPoints = f . runIdentity . L.purely S.fold_ ((,,,) <$> L.premap (^?! _2) L.maximum <*> L.premap (^?! _2) L.minimum diff --git a/src/Dodge/CullBox.hs b/src/Dodge/CullBox.hs index e69f0d260..f9de9389e 100644 --- a/src/Dodge/CullBox.hs +++ b/src/Dodge/CullBox.hs @@ -7,15 +7,14 @@ import Dodge.Base.Window import Geometry import Dodge.Update.Camera +import Data.Maybe import Control.Lens findBoundDists :: Configuration -> World -> (Float,Float,Float,Float) findBoundDists cfig w | debugOn Bound_box_screen cfig = (hh,-hh,hw,-hw) - | otherwise = f $ farWallDistDirection (_cameraCenter w) w + | otherwise = fromMaybe (0,0,0,0) $ farWallDistDirection (_cameraCenter w) w where - f (Just a,Just b,Just c,Just d) = (max 0 a,min 0 b,max 0 c,min 0 d) - f _ = (0,0,0,0) hw = halfWidth cfig hh = halfHeight cfig diff --git a/src/Dodge/Placement/Instance/LightSource.hs b/src/Dodge/Placement/Instance/LightSource.hs index 6f2981be7..9d83f3718 100644 --- a/src/Dodge/Placement/Instance/LightSource.hs +++ b/src/Dodge/Placement/Instance/LightSource.hs @@ -55,7 +55,7 @@ mntLSOn -> Maybe Color -- ^ describing a possible color override for the shape -> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) - = ps0jPushPS (PutShape . setCol $ shapeF wallp lsp) + = ps0jPushPS (putShape . setCol $ shapeF wallp lsp) . pt0 (PutLS $ ls & lsParam . lsPos .~ lsp') where lsp' = lsp -.-.- V3 x y 1 @@ -144,26 +144,26 @@ mntLightLnkCond ps = RandomPlacement $ do spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement spanLSLightI ls h a b = ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h) - $ sps0 $ PutShape $ thinHighBar h a b + $ sps0 $ putShape $ thinHighBar h a b where V2 x y = 0.5 *.* (a +.+ b) spanLS :: LightSource -> Point2 -> Point2 -> Placement spanLS ls a b = Placement 10 (PS (V2 x y) 0) (PutLS ls) Nothing - $ const $ const $ Just $ sps0 $ PutShape $ thinHighBar h a b + $ const $ const $ Just $ sps0 $ putShape $ thinHighBar h a b where V3 _ _ h = _lsPos (_lsParam ls) + 5 V2 x y = 0.5 *.* (a +.+ b) spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement spanColLightI col h a b = ps0j (PutLS $ lsColPos col (V3 x y (h-5))) - $ sps0 $ PutShape $ thinHighBar h a b + $ sps0 $ putShape $ thinHighBar h a b where V2 x y = 0.5 *.* (a +.+ b) spanColLightBlackI :: Point3 -> Float -> Point2 -> Point2 -> Placement spanColLightBlackI col h a b = ps0j (PutLS $ lsColPos col (V3 x y (h-5))) - $ sps0 $ PutShape $ colorSH black $ thinHighBar h a b + $ sps0 $ putShape $ colorSH black $ thinHighBar h a b where V2 x y = 0.5 *.* (a +.+ b) diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs index 7f46a884b..69fe1c1e2 100644 --- a/src/Dodge/Placement/Instance/Wall.hs +++ b/src/Dodge/Placement/Instance/Wall.hs @@ -6,9 +6,7 @@ import Dodge.Default.Block --import Dodge.Block.Debris import Dodge.LevelGen.Data import Dodge.Default.Wall ---import Dodge.Wall.DamageEffect import Geometry -import Shape import Color import Data.List @@ -26,16 +24,7 @@ invisibleWall ps = sps0 $ PutWall ps $ defaultWall } midWall :: [Point2] -> Placement -midWall ps = ps0j (PutShape . colorSH col $ upperPrismPoly 50 ps) - $ sps0 $ PutWall ps theWall - where - col = _wlColor defaultWall - theWall = defaultWall - { _wlOpacity = SeeAbove - , _wlDraw = False - , _wlHeight = 50 - } - +midWall = heightWallPS (PS 0 0) 50 singleBlock :: Point2 -> [Placement] singleBlock a = diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index 568222953..959173cfa 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -93,7 +93,7 @@ airlockZ = defaultRoom inDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 (-61) 0) cenlight = mntLS vShape (V2 90 60) (V3 90 40 50) `addPlmnt` mntLS vShape (V2 90 60) (V3 90 80 50) cornlight = mntLS vShape (V2 0 120) (V3 30 90 50) `addPlmnt` mntLS vShape (V2 180 120) (V3 150 90 50) - `addPlmnt` sps0 (PutShape (thinHighBar 50 (V2 30 90) (V2 150 90))) + `addPlmnt` sps0 (putShape (thinHighBar 50 (V2 30 90) (V2 150 90))) lighting = RandomPlacement $ takeOne [cenlight,cornlight] airlock90 :: Room diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index 7cf700315..3a02762c5 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -45,8 +45,8 @@ keyholeCorridor :: Room keyholeCorridor = corridor { _rmPath = [] , _rmPmnts = - [ midWall $ reverse $ rectNSWE top bot 15 0 - , midWall $ reverse $ rectNSWE top bot 40 25] + [ midWall $ rectNSWE top bot 15 0 + , midWall $ rectNSWE top bot 40 25] } where top = 65 diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index 4484c327b..9dac2b0fd 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -5,6 +5,7 @@ import Picture import Geometry import Shape import Quaternion +import Bound --import Dodge.Data.ForegroundShape import Dodge.Default.Foreground @@ -12,6 +13,8 @@ import Data.List import Data.Maybe import Control.Lens import ShapePicture +import Streaming +import qualified Streaming.Prelude as S highDiagonalMesh :: Point2 @@ -125,8 +128,11 @@ putShape sh = PutForeground $ defaultForeground bnds = shapeBounds sh m = midBounds bnds +shapePoints :: Shape -> Stream (Of Point2) Identity () +shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs) + shapeBounds :: Shape -> (Float,Float,Float,Float) -shapeBounds sh = undefined +shapeBounds = fromMaybe (0,0,0,0) . boundPoints . shapePoints midBounds :: (Float,Float,Float,Float) -> Point2 midBounds (n,s,e,w) = V2 ((n + s)/2) ((e + w)/2) diff --git a/src/Dodge/Room/LasTurret.hs b/src/Dodge/Room/LasTurret.hs index 5cb8177c4..fb21b386c 100644 --- a/src/Dodge/Room/LasTurret.hs +++ b/src/Dodge/Room/LasTurret.hs @@ -122,12 +122,12 @@ lasCenSensEdge n = do lasTunnel :: RandomGen g => Float -> State g Room lasTunnel y = do extraPlmnts <- takeOne - [ [ midWall (reverse $ rectNSWE 115 90 0 60) - , midWall (reverse $ rectNSWE 65 40 (-40) 25) + [ [ midWall ( rectNSWE 115 90 0 60) + , midWall ( rectNSWE 65 40 (-40) 25) ] - , [ midWall (reverse $ rectNSWE 125 100 0 25) - , midWall (reverse $ rectNSWE 80 40 (-40) 0) - , midWall (reverse $ rectNSWE 80 40 25 60) + , [ midWall ( rectNSWE 125 100 0 25) + , midWall ( rectNSWE 80 40 (-40) 0) + , midWall ( rectNSWE 80 40 25 60) ] ] return defaultRoom diff --git a/src/Dodge/Room/Modify/Girder.hs b/src/Dodge/Room/Modify/Girder.hs index cf40ac15e..8e3818417 100644 --- a/src/Dodge/Room/Modify/Girder.hs +++ b/src/Dodge/Room/Modify/Girder.hs @@ -36,7 +36,7 @@ addGirderNS shapef col room = do (sps0 PutNothing : [ twoRoomPoss (isUnusedLnkType (FromEdge West i)) (isUnusedLnkType (FromEdge West i)) - $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) + $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) | i <- girderPosOrder] ) @@ -44,7 +44,7 @@ addGirderFrom :: CardinalPoint -> Int -> (Point2 -> Point2 -> Shape) -> Color -> addGirderFrom cp fromi shapef col = rmPmnts .:~ foldr1 setFallback [ sps0 PutNothing , twoRoomPoss rmposcond rmposcond - $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) ] + $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) ] where rmposcond = isUnusedLnkType (FromEdge cp fromi) -- | Allows girder to be on edge @@ -56,7 +56,7 @@ addGirderNS' shapef col room = do (sps0 PutNothing : [ twoRoomPoss (isUnusedLnkType (FromEdge West i)) (isUnusedLnkType (FromEdge West i)) - $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) + $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) | i <- girderPosOrder] ) addGirderEW :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room @@ -68,7 +68,7 @@ addGirderEW shapef col room = do [ twoRoomPoss (isUnusedLnkType (FromEdge South i)) (isUnusedLnkType (FromEdge South i)) - $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) + $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) | i <- girderPosOrder] ) @@ -86,7 +86,7 @@ addGirder shapef col room = do girdson f numlnks = [ twoRoomPoss (isUnusedLnkType (f i)) (isUnusedLnkType (f i)) - $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) + $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) | i <- [1 .. numlnks - 2] ] addGirder' :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room @@ -102,7 +102,7 @@ addGirder' shapef col room = do girdson f numlnks = [ twoRoomPoss (isUnusedLnkType (f i)) (isUnusedLnkType (f i)) - $ \ps1 ps2 -> sps0 $ PutShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) + $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) | i <- [0 .. numlnks - 1] ] addHighGirder :: RandomGen g => Room -> State g Room diff --git a/src/Dodge/Room/SensorDoor.hs b/src/Dodge/Room/SensorDoor.hs index 92bb03117..9321533d1 100644 --- a/src/Dodge/Room/SensorDoor.hs +++ b/src/Dodge/Room/SensorDoor.hs @@ -15,20 +15,8 @@ import Dodge.Room.Ngon import Dodge.Room.Procedural import Dodge.Room.Corridor import Dodge.Room.Link ---import Dodge.Room.Procedural -import Dodge.Room.Foreground ---import Dodge.Room.RoadBlock import Dodge.Placement.Instance ---import Dodge.Default.Room ---import Dodge.Item.Weapon.BulletGuns ---import Dodge.Item.Weapon.Utility ---import Dodge.LevelGen.Data ---import Geometry.Data import Geometry ---import Padding -import Color -import Shape ---import Lorem import LensHelp import RandomHelp diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 04933340e..e6bb40550 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -16,6 +16,7 @@ import Geometry --import Geometry.ConvexPoly import Dodge.GameRoom import LensHelp +import Bound import qualified Data.Map.Strict as M --import qualified Data.List.NonEmpty as NEL @@ -28,7 +29,6 @@ import qualified Data.IntMap.Strict as IM import qualified SDL --import Data.Monoid --import Data.Semigroup -import qualified Control.Foldl as L import qualified Streaming.Prelude as S import Streaming {- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers; @@ -219,13 +219,14 @@ gameRoomViewpoints p gr = S.each (_grViewpoints gr) extend outp = p +.+ maxViewDistance *.* squashNormalizeV (outp -.- p) addDir a = p +.+ unitVectorAtAngle a -farWallDistDirection :: Point2 -> World -> (Maybe Float,Maybe Float,Maybe Float,Maybe Float) -farWallDistDirection p w = 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 - ) +farWallDistDirection :: Point2 -> World -> Maybe (Float,Float,Float,Float) +farWallDistDirection p w = boundPoints +-- 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 +-- ) $ S.map f vps where f q = runIdentity (S.fold_ findPoint q (rotateV (negate $ _cameraRot w) . (-.- p)) (wls q))