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

Change poke to use folding rather than store incremental ints in vector

Browse Source
This commit is contained in:
justin
2022-06-27 15:33:24 +01:00
parent 0def31895f
commit 8b72df2772
9 changed files with 78 additions and 93 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
-4
View File
@@ -61,7 +61,6 @@ import Geometry.ConvexPoly
import Sound.Data
import Dodge.GameRoom
import Color
import Shape
import Data.Tile
import MaybeHelp
@@ -141,7 +140,6 @@ data World = World
, _playingSounds :: M.Map SoundOrigin Sound
, _decorations :: IM.IntMap Picture
, _shapes :: IM.IntMap ForegroundShape
, _foregroundShape :: Shape
, _corpses :: IM.IntMap Corpse
, _clickMousePos :: Point2
, _pathGraph :: Gr Point2 Float
@@ -1402,10 +1400,8 @@ data PSType = PutCrit {_unPutCrit :: Creature}
, _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2}
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
| PutSlideDr Door Wall Float Point2 Point2
-- | PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float
| PutDoor Color (World -> Bool) [(Point2,Point2)]
| RandPS (State StdGen PSType)
| PutShape Shape
| PutForeground ForegroundShape
| PutWorldUpdate (PlacementSpot -> World -> World)
| PutNothing
src/Dodge/Default/World.hs
-1
View File
@@ -90,7 +90,6 @@ defaultWorld = World
--, _keyConfig = defaultKeyConfigSDL
-- , _config = defaultConfig
, _sideEffects = return
, _foregroundShape = mempty
, _shapes = mempty
, _distortions = []
, _gameRooms = []
src/Dodge/Floor.hs
+9 -9
View File
@@ -42,17 +42,17 @@ initialAnoTree = OnwardList
$ intersperse (AnTree corDoor)
[ IntAnno $ AnTree . startRoom
, AnRoom $ return airlock0
-- , AnRoom slowDoorRoom
, AnRoom slowDoorRoom
-- , AnRoom $ roomCCrits 10
-- , AnTree firstBreather
, AnTree firstBreather
-- , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
]
extraAnoList :: [Annotation]
extraAnoList =
-- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
[ AnRoom $ roomCCrits 10
, AnRoom $ roomCCrits 10
-- ]
--
--extraAnoList :: [Annotation]
--extraAnoList =
---- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
-- [ AnRoom $ roomCCrits 10
-- , AnRoom $ roomCCrits 10
, AnTree $ tToBTree "spawners" <$> spawnerRoom
, AnRoom pistolerRoom
, AnRoom doubleCorridorBarrels
src/Dodge/Layout.hs
-34
View File
@@ -10,7 +10,6 @@ import Dodge.Placement.PlaceSpot
--import Dodge.LevelGen.Data
import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.LevelStructure
import Dodge.Room.Foreground
import Dodge.Wall.Zone
import Dodge.GameRoom
import Dodge.Default.Wall
@@ -21,9 +20,6 @@ import Geometry
import qualified IntMapHelp as IM
import Tile
import RandomHelp
import Color
import Shape
--import Padding
import qualified Data.Set as S
import Data.List (nubBy)
@@ -38,7 +34,6 @@ generateLevelFromRoomList :: IM.IntMap Room -> World -> World
generateLevelFromRoomList gr' w = initWallZoning
. randomCompass
. setupWorldBounds
. placeWires
. doAfterPlacements
. doInPlacements
. doOutPlacements
@@ -86,35 +81,6 @@ shuffleRoomPos rm = do
newPos <- shuffle $ _rmPos rm
return $ rm & rmPos .~ newPos
placeWires :: World -> World
placeWires w = foldr placeRoomWires w (_genRooms w)
placeRoomWires :: Room -> World -> World
placeRoomWires rm w = IM.foldr ($) w
$ IM.intersectionWith (placeWire rm) (_rmStartWires rm) (_rmEndWires rm)
placeWire :: Room -> RoomWire -> RoomWire -> World -> World
placeWire rm (WallWire p _ h1) (WallWire q _ h2) = foregroundShape
%~ (col ( thinHighBarChain h2 (map (shiftPointBy rs) doOrdering)
<> barPP 1.5 (addZ h1 p) (addZ h2 p)
)
<>
)
where
--TODO use rmWalls for non convex rooms
--rmWalls = foldr cutWalls [] (_rmPolys rm)
doOrdering = orderPolygonAround rmcen (p:q:ps)
col | clockwise = colorSH red
| otherwise = colorSH red
rmps = concat $ _rmPolys rm
rmcen = centroid rmps
clockwise = isLHS rmcen p q
ps | clockwise = filter leftprightq rmps
| otherwise = filter rightpleftq rmps
leftprightq x = isLHS rmcen p x && isRHS rmcen q x
rightpleftq x = isRHS rmcen p x && isLHS rmcen q x
rs = _rmShift rm
doAfterPlacements :: World -> World
doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw)
src/Dodge/Placement/PlaceSpot.hs
-12
View File
@@ -5,21 +5,15 @@
module Dodge.Placement.PlaceSpot
( placeSpot
) where
--import Dodge.LevelGen.LevelStructure
import Dodge.Placement.Shift
import Dodge.Data
import Dodge.Path
import Dodge.Placement.PlaceSpot.Block
import Dodge.Placement.PlaceSpot.TriggerDoor
--import Dodge.LevelGen.Data
import Dodge.Default.Wall
import Dodge.ShiftPoint
import Dodge.Base.NewID
--import Dodge.RandomHelp
--import Dodge.Placements.Spot
import Geometry
--import Geometry.ConvexPoly
import Shape
import qualified IntMapHelp as IM
import Color
@@ -109,7 +103,6 @@ placeSpotID ps pt w = case pt of
wl w
PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w)
PutShape sh -> placeShape sh p rot w
PutNothing -> (0,w)
PutID i -> (i, w)
PutWorldUpdate f -> (0, w & f ps)
@@ -121,11 +114,6 @@ placeSpotID ps pt w = case pt of
rot = _psRot ps
doShift = shiftPointBy (p,rot)
placeShape :: Shape -> Point2 -> Float -> World -> (Int, World)
placeShape sh p rot w = (0, w & foregroundShape %~ (newsh <>))
where
newsh = (uncurryV translateSHf p . rotateSH rot) sh
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World)
evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w)
where
src/Dodge/Render/ShapePicture.hs
+1 -5
View File
@@ -20,7 +20,6 @@ import Dodge.Wall.Zone
import Geometry
import Geometry.Zone
import ShapePicture
import Shape
import Picture
import Sound.Data
import Geometry.ConvexPoly
@@ -35,7 +34,7 @@ import qualified Streaming.Prelude as S
-- TODO only filter out shapes outside the range of the furthest shown light source
worldSPic :: Configuration -> World -> SPic
worldSPic cfig w =
(extraShapes w, extraPics cfig w)
(mempty, extraPics cfig w)
--(mempty, extraPics cfig w)
<> foldMap (dbArg _prDraw) (filtOn _prPos _props)
<> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
@@ -60,9 +59,6 @@ cullPoint cfig w p
| debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox w)
| otherwise = dist (_cameraCenter w) p < _viewDistance w
extraShapes :: World -> Shape
extraShapes = _foregroundShape
-- TODO filter out pictures not in the frame
extraPics :: Configuration -> World -> Picture
extraPics cfig w = pictures (_decorations w)
src/Dodge/Room/Foreground.hs
+3 -4
View File
@@ -141,12 +141,11 @@ radBounds :: (Float, Float,Float,Float) -> Float
radBounds (n,s,e,w) = max (n-s) (e-w) / 2
girderV'
:: Float -- ^ "cap" size
-> Float -- ^ height
:: Float -- ^ height
-> Float -- ^ distance between cross bars
-> Float -- ^ width
-> Point2 -> Point2 -> ForegroundShape
girderV' csize h d w x y = defaultForeground
girderV' h d w x y = defaultForeground
& fsPos .~ m
& fsRad .~ dist m x
& fsSPic .~ noPic sh
@@ -157,7 +156,7 @@ girderV' csize h d w x y = defaultForeground
sh = thinHighBar h (x' -.- n) (x' +.+ n)
<> thinHighBar h (y' -.- n) (y' +.+ n)
<> girderV h d w x' y'
n = csize *.* vNormal (normalizeV (x' -.- y'))
n = min (w + 10) 20 *.* vNormal (normalizeV (x' -.- y'))
girderV
:: Float -- ^ height
src/Dodge/Room/Modify/Girder.hs
+3 -3
View File
@@ -151,13 +151,13 @@ addGirderLights rm = do
midw = wiToFloat rm midi
extragirderpos = nub $ map (\(wi,hi) -> (wi - midi, hi)) lpis
extragirders = mapMaybe (\(i,hi) -> case i of
x | x < 0 -> Just $ girderV' 20 96 20 10 (V2 (midw - 10) (hiToFloat rm hi))
x | x < 0 -> Just $ girderV' 96 20 10 (V2 (midw - 10) (hiToFloat rm hi))
(V2 0 (hiToFloat rm hi))
x | x > 0 -> Just $ girderV' 20 96 20 10 (V2 (midw + 10) (hiToFloat rm hi))
x | x > 0 -> Just $ girderV' 96 20 10 (V2 (midw + 10) (hiToFloat rm hi))
(V2 w (hiToFloat rm hi))
_ -> Nothing
) extragirderpos
return $ rm & rmPmnts .++~
(sps0 (PutForeground $ girderV' 20 96 20 10 (V2 midw 0) (V2 midw h))
(sps0 (PutForeground $ girderV' 96 20 10 (V2 midw 0) (V2 midw h))
: map (\p -> sps (PS p 0) (PutLS $ lsColPos 0.75 (V3 0 0 90))) lps
) ++ map (sps0 . PutForeground) extragirders
src/Shader/Poke.hs
+62 -21
View File
@@ -106,31 +106,54 @@ pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort
-> IO ()
pokeTopPrism size ptr iptr ieptr counts svs = do
nv <- UMV.unsafeRead counts 0
nshapeindices <- UMV.unsafeRead counts 1
nedgeindices <- UMV.unsafeRead counts 2
-- MP.bindM3 (\_ _ _ -> return ())
-- (UV.mapM_ (pokeTopPrismIndex nv iptr counts) (memoTopPrismIndices V.! size))
-- (UV.mapM_ (pokeTopPrismEdgeIndex nv ieptr counts) (memoTopPrismEdgeIndices V.! size))
-- (VS.mapM_ (pokeJustV ptr counts) (VS.fromList svs) )
UV.mapM_ (pokeTopPrismIndex nv iptr counts) (memoTopPrismIndices V.! size)
UV.mapM_ (pokeTopPrismEdgeIndex nv ieptr counts) (memoTopPrismEdgeIndices V.! size)
VS.mapM_ (pokeJustV ptr counts) (VS.fromList svs)
nv' <- VS.foldM (pokeJustV' ptr) nv (VS.fromList svs)
nshapeindices' <- UV.foldM (pokeTopPrismIndex' nv iptr) nshapeindices
(memoTopPrismIndices V.! size)
nedgeindices' <- UV.foldM (pokeTopPrismEdgeIndex' nv ieptr) nedgeindices
(memoTopPrismEdgeIndices V.! size)
UMV.unsafeWrite counts 0 nv'
UMV.unsafeWrite counts 1 nshapeindices'
UMV.unsafeWrite counts 2 nedgeindices'
pokeTopPrismEdgeIndex :: Int -> Ptr GLushort
-> UMV.MVector (PrimState IO) Int
pokeTopPrismEdgeIndex' :: Int -> Ptr GLushort
-> Int
-> Int
-> IO ()
pokeTopPrismEdgeIndex nv eiptr counts ioff = do
nei <- UMV.unsafeRead counts 2
pokeElemOff eiptr nei (fromIntegral $ nv + ioff)
UMV.unsafeModify counts (+1) 2
-> IO Int
pokeTopPrismEdgeIndex' nv eiptr nedgeindices ioff = do
pokeElemOff eiptr nedgeindices (fromIntegral $ nv + ioff)
return $ nedgeindices + 1
pokeTopPrismIndex :: Int -> Ptr GLushort
-> UMV.MVector (PrimState IO) Int
--pokeTopPrismEdgeIndex :: Int -> Ptr GLushort
-- -> UMV.MVector (PrimState IO) Int
-- -> Int
-- -> IO ()
--pokeTopPrismEdgeIndex nv eiptr counts ioff = do
-- nei <- UMV.unsafeRead counts 2
-- pokeElemOff eiptr nei (fromIntegral $ nv + ioff)
-- UMV.unsafeModify counts (+1) 2
pokeTopPrismIndex' :: Int -> Ptr GLushort
-> Int
-> Int
-> IO ()
pokeTopPrismIndex nv iptr counts ioff = do
ni <- UMV.unsafeRead counts 1
pokeElemOff iptr ni (fromIntegral $ nv + ioff)
UMV.unsafeModify counts (+1) 1
-> IO Int
pokeTopPrismIndex' nv iptr nshapeindices ioff = do
pokeElemOff iptr nshapeindices (fromIntegral $ nv + ioff)
return $ nshapeindices + 1
--pokeTopPrismIndex :: Int -> Ptr GLushort
-- -> UMV.MVector (PrimState IO) Int
-- -> Int
-- -> IO ()
--pokeTopPrismIndex nv iptr counts ioff = do
-- ni <- UMV.unsafeRead counts 1
-- pokeElemOff iptr ni (fromIntegral $ nv + ioff)
-- UMV.unsafeModify counts (+1) 1
memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int)
memoTopPrismEdgeIndices = V.generate 10
@@ -164,9 +187,11 @@ topPrismIndices n = concatMap f [1..n-2] -- triangles on top face
g x = [2*x,2*x+1,2*x+3
,2*x,2*x+3,2*x+2]
pokeJustV :: Ptr Float -> UMV.MVector (PrimState IO) Int -> ShapeV -> IO ()
pokeJustV ptr counts sh = do
nv <- UMV.unsafeRead counts 0
pokeJustV' :: Ptr Float
-> Int
-> ShapeV
-> IO Int
pokeJustV' ptr nv sh = do
let off i = nv*7 + i
pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b
@@ -175,11 +200,27 @@ pokeJustV ptr counts sh = do
pokeElemOff ptr (off 4) e
pokeElemOff ptr (off 5) f
pokeElemOff ptr (off 6) g
UMV.unsafeModify counts (+1) 0
return (nv + 1)
where
V3 a b c = _svPos sh
V4 d e f g = _svCol sh
--pokeJustV :: Ptr Float -> UMV.MVector (PrimState IO) Int -> ShapeV -> IO ()
--pokeJustV ptr counts sh = do
-- nv <- UMV.unsafeRead counts 0
-- let off i = nv*7 + i
-- pokeElemOff ptr (off 0) a
-- pokeElemOff ptr (off 1) b
-- pokeElemOff ptr (off 2) c
-- pokeElemOff ptr (off 3) d
-- pokeElemOff ptr (off 4) e
-- pokeElemOff ptr (off 5) f
-- pokeElemOff ptr (off 6) g
-- UMV.unsafeModify counts (+1) 0
-- where
-- V3 a b c = _svPos sh
-- V4 d e f g = _svCol sh
pokeLayVerxs
:: MV.MVector (PrimState IO) FullShader
-> UMV.MVector (PrimState IO) Int