Create post world load function

shader/texture/arrayPos.frag

@@ -4,7 +4,7 @@ in vec3 vPos;
 layout (location=0) out vec4 fCol;
 layout (location=1) out vec4 fPos;
 layout (location=2) out vec4 normal;
-layout (binding=0) uniform sampler2DArray tilesetSampler;
+//layout (binding=0) uniform sampler2DArray tilesetSampler;
 layout (binding=1) uniform sampler2D normalSampler;
 void main()
 {

src/Data/Tile.hs

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 :: RenderData -> Int -> IO World
-generateWorldFromSeed i = do
+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 $!
+    postGenerationProcessing rdata
-            _gwWorld (generateLevelFromRoomList roomList initialWorld{_randGen = mkStdGen i})
+        $! (generateLevelFromRoomList roomList initialWorld{_randGen = mkStdGen i})
-                & cWorld . cwGen . cwgRoomClipping .~ bounds
+        & gwWorld . cWorld . cwGen . cwgRoomClipping .~ bounds
-                & cWorld . cwGen . cwgSeed .~ i
+        & gwWorld . cWorld . cwGen . cwgSeed .~ i
 
-postGenerationProcessing :: World -> IO World
+postGenerationProcessing :: RenderData -> GenWorld -> IO World
-postGenerationProcessing w =
+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

@@ -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
+            ( pokeWallsWindows
-                --(shadVBOptr $ _wallTextureShader pdata)
-                --(shadVBOptr $ _windowShader pdata)
                 ( 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)
+--    glUseProgram (pdata ^. textureArrayShader . _1 . shadName)
-    glBindVertexArray $ pdata ^. textureArrayShader . _1 . shadVAO . vaoName
+--    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

@@ -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,9 +3,7 @@ module Dodge.StartNewGame (
     startSeedGame,
 ) where
 
-import Data.Preload.Render
+import Dodge.WorldLoad
-import Shader.Data
-import Shader.Poke -- it would be very nice to remove/rework the poking dependencies
 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
+    w <- generateWorldFromSeed (pdata ^?! renderData) seed
-    nfloorvxs <- pokeFloors (pdata ^?! renderData . textureArrayShader . _2 . vboPtr)
-        (w' ^. cWorld . floorTiles)
-    let w = w' & numberFloorVerxs .~ nfloorvxs
     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

@@ -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
+    floorvbo <- setupVBO' floorverxstrd
-    floorshader <- makeShader4 "floor/arrayPos" [vert, frag] [4,4] floorverxstrd ETriangles vbofloor
+    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

@@ -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

@@ -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,7 +1,5 @@
 module Tile
-    ( tileToRenderList
+     where
-    , makeTileFromPoly
-    ) where
 import Data.Tile
 import Geometry