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

Create post world load function

Browse Source
This commit is contained in:
justin
2023-03-18 09:37:09 +00:00
parent d8fb7a1f99
commit 77c88f68a7
14 changed files with 80 additions and 48 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Data/Tile.hs
+3
View File
@@ -2,6 +2,8 @@
--{-# LANGUAGE StrictData #-}
module Data.Tile where
import Geometry.Data
import Data.Aeson
import Data.Aeson.TH
import Control.Lens
@@ -18,3 +20,4 @@ data Tile = Tile
deriving (Eq, Ord, Show)
makeLenses ''Floor
makeLenses ''Tile
deriveJSON defaultOptions ''Tile
src/Dodge/Data/CWorld.hs
+3
View File
@@ -9,6 +9,7 @@ module Dodge.Data.CWorld (
module Dodge.Data.CamPos
) where
import Data.Tile
import Geometry.Data
import Dodge.Data.LWorld
import Control.Lens
@@ -30,7 +31,9 @@ data CWorld = CWorld
, _timeFlow :: TimeFlowStatus
, _seenWalls :: IS.IntSet
, _floorTiles :: [(Point3, Point3)]
, _cwTiles :: [Tile]
, _pathGraph :: Gr Point2 PathEdge
, _numberFloorVerxs :: Int
}
data TimeFlowStatus
src/Dodge/Data/World.hs
-1
View File
@@ -48,7 +48,6 @@ data World = World
, _pnZoning :: IntMap (IntMap [(Int, Point2)]) --Zoning IM.IntMap Creature
, _peZoning :: IntMap (IntMap (Set PathEdgeNodes))
, _gsZoning :: IntMap (IntMap IntSet)
, _numberFloorVerxs :: Int
}
-- deriving (Eq, Ord, Show, Read) --Generic, Flat)
src/Dodge/Default/World.hs
+2 -1
View File
@@ -48,7 +48,6 @@ defaultWorld =
, _pnZoning = mempty
, _peZoning = mempty
, _gsZoning = mempty --Zoning IM.empty clZoneSize (zonePos _guPos)
, _numberFloorVerxs = 0
}
defaultCWGen :: CWGen
@@ -88,6 +87,8 @@ defaultCWorld =
, _floorTiles = mempty
--, _pathGraph = mempty
, _pathGraph = Data.Graph.Inductive.Graph.empty
, _cwTiles = mempty
, _numberFloorVerxs = 0
}
defaultLWorld :: LWorld
src/Dodge/Layout.hs
+4
View File
@@ -1,6 +1,7 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Layout (
generateLevelFromRoomList,
tilesFromRooms,
) where
import Dodge.Path.Translate
@@ -211,6 +212,9 @@ gameRoomFromRoom rm =
floorsFromRooms :: [Room] -> [(Point3, Point3)]
floorsFromRooms = concatMap (concatMap tileToRenderList . getTiles . _rmFloor . doRoomShift)
tilesFromRooms :: [Room] -> [Tile]
tilesFromRooms = concatMap (getTiles . _rmFloor . doRoomShift)
floorsFromGenWorld :: GenWorld -> [(Point3, Point3)]
floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms
src/Dodge/LevelGen.hs
+17 -9
View File
@@ -1,5 +1,7 @@
module Dodge.LevelGen where
import Dodge.Layout
import Data.Preload.Render
import Control.Lens
import Control.Monad.State
import Data.Foldable
@@ -8,15 +10,14 @@ import Dodge.Combine.Graph
import Dodge.Data.GenWorld
import Dodge.Floor
import Dodge.Initialisation
import Dodge.Layout
import Dodge.Tree
import Geometry.ConvexPoly
import qualified IntMapHelp as IM
import System.Directory
import System.Random
generateWorldFromSeed :: Int -> IO World
generateWorldFromSeed i = do
generateWorldFromSeed :: RenderData -> Int -> IO World
generateWorldFromSeed rdata i = do
createDirectoryIfMissing True "log"
createDirectoryIfMissing True "graph"
writeFile "log/attemptedSeeds" ""
@@ -24,13 +25,20 @@ generateWorldFromSeed i = do
writeFile "log/aGeneratedRoomLayout" ""
generateGraphs
(roomList, bounds) <- layoutLevelFromSeed 0 i
postGenerationProcessing $!
_gwWorld (generateLevelFromRoomList roomList initialWorld{_randGen = mkStdGen i})
& cWorld . cwGen . cwgRoomClipping .~ bounds
& cWorld . cwGen . cwgSeed .~ i
postGenerationProcessing rdata
$! (generateLevelFromRoomList roomList initialWorld{_randGen = mkStdGen i})
& gwWorld . cWorld . cwGen . cwgRoomClipping .~ bounds
& gwWorld . cWorld . cwGen . cwgSeed .~ i
postGenerationProcessing :: World -> IO World
postGenerationProcessing w =
postGenerationProcessing :: RenderData -> GenWorld -> IO World
postGenerationProcessing _ gw = do
let w' = _gwWorld gw
-- nfloorvxs <- foldM (pokeTile (rdata ^. floorVBO . vboPtr))
-- 0
-- (tilesFromRooms . IM.elems $ _genRooms gw)
-- bufferPokedVBO (rdata ^. floorVBO) nfloorvxs
let w = w' -- & cWorld . numberFloorVerxs .~ nfloorvxs
& cWorld . cwTiles .~ (tilesFromRooms . IM.elems $ _genRooms gw)
return $ foldl' assignPushDoors w (w ^. cWorld . lWorld . doors)
generateGraphs :: IO ()
src/Dodge/Render.hs
+17 -13
View File
@@ -56,12 +56,13 @@ doDrawing' win pdata u = do
lightPoints = lightsToRender cfig (w ^. cWorld . camPos) (w ^. cWorld . lWorld)
viewFroms@(V2 vfx vfy) = w ^. cWorld . camPos . camViewFrom
shadV = _pictureShaders pdata
nFls = w ^. cWorld . numberFloorVerxs
-- bind as much data into vbos as feasible at this point
-- count mutable vectors setup
layerCounts <- UMV.replicate (numLayers * 6) 0
-- attempt to poke in parallel
let (ws, wp) = wallSPics <> worldSPic cfig w
((nWalls, nWins, nFls), (nShapeVs, nIndices, nSilIndices)) <-
((nWalls, nWins), (nShapeVs, nIndices, nSilIndices)) <-
MP.bindM3
(\_ a b -> return (a, b))
( pokeLayVerxs
@@ -69,15 +70,11 @@ doDrawing' win pdata u = do
layerCounts
wp
)
( pokeWallsWindowsFloor
--(shadVBOptr $ _wallTextureShader pdata)
--(shadVBOptr $ _windowShader pdata)
( pokeWallsWindows
( pdata ^. vboWalls . vboPtr)
( pdata ^. vboWindows . vboPtr)
(shadVBOptr $ _textureArrayShader pdata)
wallPointsCol
windowPoints
(w ^. cWorld . floorTiles)
)
( pokeShape
(_vboPtr $ _vboShapes pdata)
@@ -92,7 +89,7 @@ doDrawing' win pdata u = do
unzip
[ (pdata ^. vboWalls, nWalls)
, (pdata ^. vboWindows, nWins)
, (snd $ _textureArrayShader pdata, nFls)
, (pdata ^. floorVBO, nFls)
]
bufferPokedVBO (_vboShapes pdata) nShapeVs
glNamedBufferSubData
@@ -158,17 +155,24 @@ doDrawing' win pdata u = do
(fromIntegral nIndices)
GL_UNSIGNED_SHORT
nullPtr
-- glDisable GL_CULL_FACE
glDisable GL_CULL_FACE
--draw floor onto base buffer
glDisable GL_BLEND
glUseProgram (pdata ^. textureArrayShader . _1 . shadName)
glBindVertexArray $ pdata ^. textureArrayShader . _1 . shadVAO . vaoName
-- glUseProgram (pdata ^. textureArrayShader . _1 . shadName)
-- glBindVertexArray $ pdata ^. textureArrayShader . _1 . shadVAO . vaoName
-- glBindTextureUnit 1 (pdata ^. toNormalMaps . unTO)
---- glBindTextureUnit 0 $ pdata ^?! textureArrayShader . _1 . shadTex' . _Just . textureObject
-- glDrawArrays
-- (marshalEPrimitiveMode $ pdata ^. textureArrayShader . _1 . shadPrim' )
-- 0
-- (fromIntegral nFls)
glUseProgram (pdata ^. floorShader . shadName)
glBindVertexArray $ pdata ^. floorShader . shadVAO . vaoName
glBindTextureUnit 1 (pdata ^. toNormalMaps . unTO)
glBindTextureUnit 0 $ pdata ^?! textureArrayShader . _1 . shadTex' . _Just . textureObject
glDrawArrays
(marshalEPrimitiveMode $ pdata ^. textureArrayShader . _1 . shadPrim' )
(marshalEPrimitiveMode $ pdata ^. floorShader . shadPrim' )
0
(fromIntegral nFls)
(fromIntegral $ nFls)
glEnable GL_BLEND
--draw lightmap into its own buffer
createLightMap
src/Dodge/Save.hs
-1
View File
@@ -58,7 +58,6 @@ readSaveSlot ss = do
path uv = uv ^. uvWorld . cWorld . pathGraph
removescreenlayers = Just . (uvScreenLayers .~ [])
saveSlotPath :: SaveSlot -> String
saveSlotPath (SaveSlotNum i) = "saveSlot/" ++ show i
saveSlotPath QuicksaveSlot = "saveSlot/QuickSave"
src/Dodge/StartNewGame.hs
+3 -7
View File
@@ -3,9 +3,7 @@ module Dodge.StartNewGame (
startSeedGame,
) where
import Data.Preload.Render
import Shader.Data
import Shader.Poke -- it would be very nice to remove/rework the poking dependencies
import Dodge.WorldLoad
import Dodge.Menu.Loading
import Dodge.Concurrent
--import Dodge.Menu.Option
@@ -30,12 +28,10 @@ startSeedGame _ i u = blockingLoad "LOADING" (startSeedGameConc i $ u ^. preload
startSeedGameConc :: Int -> PreloadData -> IO (Universe -> Maybe Universe)
startSeedGameConc seed pdata = do
w' <- generateWorldFromSeed seed
nfloorvxs <- pokeFloors (pdata ^?! renderData . textureArrayShader . _2 . vboPtr)
(w' ^. cWorld . floorTiles)
let w = w' & numberFloorVerxs .~ nfloorvxs
w <- generateWorldFromSeed (pdata ^?! renderData) seed
writeFile "saveSlot/seed" $ show seed
return $ Just
. saveWorldInSlot (LevelStartSlot 0)
. (uvScreenLayers .~ [])
. (uvWorld .~ w)
. (uvIOEffects %~ (\f uv -> ( (uvWorld . cWorld) (postWorldLoad (pdata ^?! renderData)) uv >>= f)))
src/Preload/Render.hs
+3 -3
View File
@@ -171,8 +171,8 @@ preloadRender = do
makeShader "texture/arrayPos" [vert, frag] [3, 3] ETriangles
>>= addTextureArray "data/texture/ayene_wooden_floor_transformed.png"
let floorverxstrd = 8
vbofloor <- setupVBO floorverxstrd
floorshader <- makeShader4 "floor/arrayPos" [vert, frag] [4,4] floorverxstrd ETriangles vbofloor
floorvbo <- setupVBO' floorverxstrd
floorshader <- makeShader4 "floor/arrayPos" [vert, frag] [4,4] floorverxstrd ETriangles floorvbo
-- bind fixed vertex data
bufferPokedVBO (snd fsShad) 4
framebuf2 <- setupTextureFramebuffer 800 600
@@ -257,7 +257,7 @@ preloadRender = do
, _vboWalls = wpVBO
, _vboWindows = winVBO
, _vboShapes = shVBO
, _floorVBO = vbofloor
, _floorVBO = floorvbo
, _floorShader = floorshader
, _toNormalMaps = tonormalmap
}
src/Shader/Compile.hs
+13
View File
@@ -1,5 +1,6 @@
module Shader.Compile (
setupVBO,
setupVBO',
makeShader,
makeShader4,
makeByteStringShaderUsingVAO,
@@ -80,6 +81,17 @@ setupVBO vertexsize = do
GL_STREAM_DRAW
return VBO {_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize}
setupVBO' :: Int -> IO VBO
setupVBO' vertexsize = do
vboname <- mglCreate glCreateBuffers
thePtr <- mallocArray (vertexsize * numDrawableElements)
-- Allocate space
glNamedBufferData vboname
( fromIntegral $ floatSize * numDrawableElements * vertexsize)
nullPtr
GL_STATIC_DRAW
return VBO {_vboName = vboname, _vboPtr = thePtr, _vboVertexSize = vertexsize}
makeByteStringShaderUsingVAO ::
-- | (Arbitrary) name of the shader
String ->
@@ -269,6 +281,7 @@ checkErrorGL str f g x statustype =
char <- peekCString charPtr
error $ str ++ show char
-- use glCreateShaderProgramv here
compileAndCheckShader :: String -> (GLenum, BS.ByteString) -> IO GLuint
compileAndCheckShader str (theShaderType, sourceCode) = do
theShader <- glCreateShader theShaderType
src/Shader/Poke.hs
+13 -9
View File
@@ -4,10 +4,12 @@ module Shader.Poke (
pokeArrayOff,
pokeShape,
pokeWallsWindowsFloor,
pokeWallsWindows,
memoTopPrismEdgeIndices,
pokeFloors
) where
import Shader.Poke.Triangulate
import Control.Monad.Primitive
import qualified Data.Vector as V
import qualified Data.Vector.Fusion.Stream.Monadic as VFSM
@@ -55,6 +57,17 @@ pokeWallsWindowsFloor wlptr wiptr flptr wls wis fls = do
flcounts <- VFSM.foldlM' (pokeF flptr) 0 (VFSM.fromList fls)
return (wlcounts1, wlcounts2, flcounts)
pokeWallsWindows ::
Ptr Float ->
Ptr Float ->
[((Point2, Point2), Point4)] ->
[((Point2, Point2), Point4)] ->
IO (Int, Int)
pokeWallsWindows wlptr wiptr wls wis = do
wlcounts1 <- VFSM.foldlM' (pokeW wlptr) 0 (VFSM.fromList wls)
wlcounts2 <- VFSM.foldlM' (pokeW wiptr) 0 (VFSM.fromList wis)
return (wlcounts1, wlcounts2)
pokeFloors :: Ptr Float ->
[(Point3, Point3)] ->
IO Int
@@ -240,15 +253,6 @@ pokeIndex nv eiptr ni ioff = do
pokeElemOff eiptr ni (fromIntegral $ nv + ioff)
return $ ni + 1
triangulate :: [Int] -> [Int]
triangulate is = V.toList . V.backpermute (V.fromList is) . V.fromList $ triangulateIndices (length is)
triangulateIndices :: Int -> [Int]
triangulateIndices i = concatMap f [0 .. i -3]
where
f x
| even x = [0, x + 1, x + 2]
| otherwise = [0, x + 2, x + 1]
memoFlatIndices :: V.Vector (UV.Vector Int)
memoFlatIndices =
src/Tile.hs
+1 -3
View File
@@ -1,7 +1,5 @@
module Tile
( tileToRenderList
, makeTileFromPoly
) where
where
import Data.Tile
import Geometry