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

Replace PutShape with PutForeground

Browse Source
This commit is contained in:
justin
2022-06-27 14:30:08 +01:00
parent fec72cdf48
commit 0def31895f
11 changed files with 39 additions and 55 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Bound.hs
+1
View File
@@ -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
src/Dodge/CullBox.hs
+2 -3
View File
@@ -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
src/Dodge/Placement/Instance/LightSource.hs
+5 -5
View File
@@ -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)
src/Dodge/Placement/Instance/Wall.hs
+1 -12
View File
@@ -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 =
src/Dodge/Room/Airlock.hs
+1 -1
View File
@@ -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
src/Dodge/Room/Corridor.hs
+2 -2
View File
@@ -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
src/Dodge/Room/Foreground.hs
+7 -1
View File
@@ -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)
src/Dodge/Room/LasTurret.hs
+5 -5
View File
@@ -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
src/Dodge/Room/Modify/Girder.hs
+6 -6
View File
@@ -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
src/Dodge/Room/SensorDoor.hs
-12
View File
@@ -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
src/Dodge/Update/Camera.hs
+9 -8
View File
@@ -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))