Correct loading of tile buffer when loading game

appDodge/Main.hs

@@ -149,8 +149,3 @@ doPreload = do
             , _soundData = SoundData{_loadedChunks = lChunks}
             , _musicData = MusicData{_loadedMusic = lMusic}
             }
-
---checkForGlErrors :: IO ()
---checkForGlErrors = do
---    errs <- errors
---    unless (null errs) $ putStrLn $ "GLerror during doLoop: " ++ unwords (map show errs)

package.yaml

@@ -65,13 +65,14 @@ executables:
     main:                Main.hs
     source-dirs:         appDodge
     ghc-options:
+    - -eventlog
     - -threaded
     - -O2
+      #- -eventlog
     - -rtsopts
-      #    - -eventlog
     - -with-rtsopts=+RTS
-    - -with-rtsopts=-N
+    - -with-rtsopts=-N2
-      #- -with-rtsopts=-l
+    - -with-rtsopts=-l
     - -flate-dmd-anal
     - -fno-liberate-case 
     - -fno-state-hack

src/Dodge/Concurrent.hs

@@ -2,10 +2,12 @@ module Dodge.Concurrent
     ( hardQuit
     , addSideEffect
     , conEffects
+    , blockingLoad
     ) where
 
 --import qualified Data.Set as S
-import Control.Lens
+import Dodge.Menu.Loading
+import LensHelp
 import Dodge.Data.Universe
 import Data.Sequence (Seq (..))
 
@@ -32,6 +34,11 @@ addSideEffect f s = uvSideEffects %~ (|> NewSideEffect f s)
 
 hardQuit :: Universe -> Universe
 hardQuit = uvSideEffects %~ (HardQuit <|)
+
+blockingLoad :: String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
+blockingLoad str f u = u & uvScreenLayers .:~ loadingScreen str
+    & addSideEffect f str
+
 --hardQuit = addSideEffect (return $ const Nothing) "QUITTING"
 
 --tryConcEffect :: Bool -> String -> IO (Universe -> Maybe Universe) -> Universe -> Universe

src/Dodge/Data/World.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -13,24 +13,25 @@ module Dodge.Data.World (
     module Dodge.Data.Input,
 ) where
 
-import Geometry.Data
+import Control.Lens
 import Data.IntMap.Strict (IntMap)
 import Data.IntSet (IntSet)
-import Data.Set (Set)
-import Dodge.Data.SaveSlot
-import Control.Lens
 import qualified Data.Map.Strict as M
+import Data.Set (Set)
 import Dodge.Data.CWorld
 import Dodge.Data.Hammer
 import Dodge.Data.Input
 import Dodge.Data.RightButtonOptions
+import Dodge.Data.SaveSlot
 import Dodge.Data.SoundOrigin
+import Geometry.Data
 import Sound.Data
 import System.Random
 
-data WorldEventFlag = InventoryChange
+data WorldEventFlag
+    = InventoryChange
     | CombineInventoryChange
-    deriving (Eq,Ord,Enum,Bounded)
+    deriving (Eq, Ord, Enum, Bounded)
 
 data World = World
     { _cWorld :: CWorld
@@ -54,7 +55,7 @@ data World = World
 
 data TimeFlowStatus
     = DeathTime
-        { _deathDelay :: Int }
+        {_deathDelay :: Int}
     | NormalTimeFlow
     | ScrollTimeFlow
         { _scrollSmoothing :: Int
@@ -71,8 +72,5 @@ data TimeFlowStatus
         , _scrollItemLocation :: Int
         }
 
-
---    deriving (Eq, Ord, Show, Read) --Generic, Flat)
-
 makeLenses ''TimeFlowStatus
 makeLenses ''World

src/Dodge/Default/World.hs

@@ -1,9 +1,9 @@
 module Dodge.Default.World where
 
 import Control.Lens
-import Dodge.Data.SelectionList
 import Data.Graph.Inductive.Graph hiding ((&))
 import qualified Data.Map as M
+import Dodge.Data.SelectionList
 import Dodge.Data.World
 import Geometry.Data
 import Geometry.Polygon
@@ -146,12 +146,6 @@ defaultLWorld =
         , _lClock = 0
         }
 
---defaultDisplaySections :: SelectionSections a
---defaultDisplaySections = SelectionSections
---    { _sssSections = mempty
---    , _sssSelPos = Just (0,0)
---    }
-
 defaultHUD :: HUD
 defaultHUD =
     HUD
@@ -163,34 +157,26 @@ defaultHUD =
         }
 
 defaultDisplayInventory :: HUDElement
-defaultDisplayInventory = DisplayInventory 
+defaultDisplayInventory =
-    {_subInventory = NoSubInventory
+    DisplayInventory
+        { _subInventory = NoSubInventory
         , _diSections = defaultInvSections
---    , _invRegex = Nothing
---    , _closeRegex = Nothing
         }
---youLight :: TempLightSource
---youLight = TLS
---    { _tlsParam = LSParam
---        {_lsPos = V3 0 0 0
---        ,_lsRad = 300
---        ,_lsCol = 0.1
---        }
---    ,_tlsUpdate = \w _ -> Just (youLight & tlsParam . lsPos .~ f (_crPos $ you w))
---    ,_tlsTime = 0
---    }
---  where
---    f (V2 x y) = V3 x y 100
 
 defaultSSSExtra :: SSSExtra
-defaultSSSExtra = SSSExtra
+defaultSSSExtra =
-        {_sssFilters = IM.fromList [(-1,mempty),(2,mempty)]
+    SSSExtra
-        ,_sssSelPos = Nothing
+        { _sssFilters = IM.fromList [(-1, mempty), (2, mempty)]
+        , _sssSelPos = Nothing
         }
 
 defaultInvSections :: SelectionSections ()
-defaultInvSections = SelectionSections
+defaultInvSections =
-    { _sssSections = IM.fromDistinctAscList $ zip [-1..]
+    SelectionSections
+        { _sssSections =
+            IM.fromDistinctAscList $
+                zip
+                    [-1 ..]
                     [ defaultFiltSection
                     , defaultInvSection
                     , defaultYouSection
@@ -200,8 +186,10 @@ defaultInvSections = SelectionSections
                     ]
         , _sssExtra = defaultSSSExtra
         }
+
 defaultSS :: SelectionSection a
-defaultSS = SelectionSection 
+defaultSS =
+    SelectionSection
         { _ssItems = mempty
         , _ssCursor = Nothing
         , _ssMinSize = 10
@@ -212,23 +200,26 @@ defaultSS = SelectionSection
         }
 
 defaultCOSection :: SelectionSection ()
-defaultCOSection = defaultSS 
+defaultCOSection =
+    defaultSS
         & ssIndent .~ 2
         & ssDescriptor .~ "CLOSE OBJECTS"
 
 defaultFiltSection :: SelectionSection a
-defaultFiltSection = defaultSS 
+defaultFiltSection =
+    defaultSS
         & ssIndent .~ 0
         & ssDescriptor .~ "INV"
         & ssMinSize .~ 0
 
 defaultInvSection :: SelectionSection ()
-defaultInvSection = defaultSS
+defaultInvSection =
+    defaultSS
         & ssDescriptor .~ "INVENTORY ITEMS"
 
 defaultYouSection :: SelectionSection ()
-defaultYouSection = defaultSS
+defaultYouSection =
---    & ssRegex .~ UnavailableRegex
+    defaultSS
         & ssIndent .~ 2
         & ssMinSize .~ 1
         & ssDescriptor .~ "YOUR STATUS"

src/Dodge/Save.hs

@@ -9,6 +9,7 @@ module Dodge.Save (
 ) where
 
 
+import Dodge.WorldLoad
 import Dodge.Path.Translate
 import Data.Graph.Inductive (labEdges, labNodes)
 import Dodge.Zoning.Pathing
@@ -41,22 +42,21 @@ writeSaveSlot ss u = do
 readSaveSlot :: SaveSlot -> IO (Universe -> Maybe Universe)
 readSaveSlot ss = do
     fExists <- doesFileExist $ saveSlotPath ss
-    if fExists
+    if not fExists then error "Tried to read non-existant save file"
-        then do
+        else return ()
-            cwstr <- decodeFileStrict $ saveSlotPath ss
+    mcw <- decodeFileStrict $ saveSlotPath ss
-            case cwstr of
+    flip (maybe (error "Tried to read incorrectly encoded save file")) mcw $ \cw ->
-                Nothing -> putStrLn "loadSaveSlot failed to read saved file" >> return removescreenlayers
+        return $ \uv -> Just 
-                Just cw -> return $ \uv -> Just $ uv & uvWorld . cWorld .~ cw
+            $ uv & uvWorld . cWorld .~ cw
                     & uvWorld %~ initWallZoning
                     & uvWorld . pnZoning .~ foldl' (flip zonePn) mempty 
                         (labNodes $ path uv)
                     & uvWorld . peZoning .~ foldl' (flip zonePe) mempty 
                         (map fromEdgeTuple $ labEdges $ path uv)
                     & uvScreenLayers .~ []
-        else putStrLn "loadSaveSlot failed to find saved file" >> return removescreenlayers
+                    & postUniverseLoadSideEffect
   where
     path uv = uv ^. uvWorld . cWorld . pathGraph
-    removescreenlayers = Just . (uvScreenLayers .~ [])
 
 saveSlotPath :: SaveSlot -> String
 saveSlotPath (SaveSlotNum i) = "saveSlot/" ++ show i
@@ -64,14 +64,13 @@ saveSlotPath QuicksaveSlot = "saveSlot/QuickSave"
 saveSlotPath (LevelStartSlot i) = "saveSlot/LevelStart" ++ show i
 
 saveWorldInSlot :: SaveSlot -> Universe -> Universe
---saveWorldInSlot slot u = u & uvSideEffects %~ (|> NewSideEffect (writeSaveSlot slot u) "SAVING")
 saveWorldInSlot slot u = u & addSideEffect (writeSaveSlot slot u) "SAVING"
     
 reloadLevelStart :: Universe -> Universe
 reloadLevelStart = loadSaveSlot (LevelStartSlot 0)
 
 loadSaveSlot :: SaveSlot -> Universe -> Universe
-loadSaveSlot slot = addSideEffect (readSaveSlot slot) "LOADING"
+loadSaveSlot slot = blockingLoad "LOADING SAVE" $ readSaveSlot slot
 
 doQuicksave :: Universe -> Universe
 doQuicksave = saveWorldInSlot QuicksaveSlot

src/Dodge/StartNewGame.hs

@@ -3,14 +3,12 @@ module Dodge.StartNewGame (
     startSeedGame,
 ) where
 
-import Dodge.WorldLoad
-import Dodge.Menu.Loading
 import Dodge.Concurrent
---import Dodge.Menu.Option
-import LensHelp
 import Dodge.Data.Universe
 import Dodge.LevelGen
 import Dodge.Save
+import Dodge.WorldLoad
+import LensHelp
 import System.Random
 
 startNewGameInSlot :: Int -> Universe -> Universe
@@ -18,20 +16,20 @@ startNewGameInSlot slot u = startSeedGame slot i u
   where
     i = fst $ randomR (0, maxBound) (_randGen (_uvWorld u))
 
-
-blockingLoad :: String -> IO (Universe -> Maybe Universe) -> Universe -> Universe
-blockingLoad str f u = u & uvScreenLayers .:~ loadingScreen str
-    & addSideEffect f str
-
 startSeedGame :: Int -> Int -> Universe -> Universe
-startSeedGame _ i u = blockingLoad "LOADING" (startSeedGameConc i $ u ^. preloadData) u
+startSeedGame _ i u =
+    blockingLoad
+        ("GENERATING FROM SEED " ++ show i)
+        (startSeedGameConc i $ u ^. preloadData)
+        u
 
 startSeedGameConc :: Int -> PreloadData -> IO (Universe -> Maybe Universe)
 startSeedGameConc seed pdata = do
     w <- generateWorldFromSeed (pdata ^?! renderData) seed
     writeFile "saveSlot/seed" $ show seed
-    return $ Just
+    return $
+        Just
             . saveWorldInSlot (LevelStartSlot 0)
             . (uvScreenLayers .~ [])
             . (uvWorld .~ w)
-        . (uvIOEffects %~ (\f uv ->  (uvWorld . cWorld) (postWorldLoad (pdata ^?! renderData)) uv >>= f))
+            . postUniverseLoadSideEffect

src/Dodge/WorldLoad.hs

@@ -1,16 +1,21 @@
 module Dodge.WorldLoad where
 
+import Control.Lens
+import Control.Monad
+import Data.Preload.Render
+import Dodge.Data.Universe
 import Shader.Bind
 import Shader.Data
 import Shader.Poke.Floor
-import Data.Preload.Render
+
-import Dodge.Data.CWorld
+postUniverseLoadSideEffect :: Universe -> Universe
-import Control.Monad
+postUniverseLoadSideEffect = (uvIOEffects %~ (\f uv -> (uvWorld . cWorld) (postWorldLoad (uv ^. preloadData . renderData)) uv >>= f))
-import Control.Lens
 
 postWorldLoad :: RenderData -> CWorld -> IO CWorld
 postWorldLoad rdata cw = do
-    nfloorvxs <- foldM (pokeTile (rdata ^. floorVBO . vboPtr))
+    nfloorvxs <-
+        foldM
+            (pokeTile (rdata ^. floorVBO . vboPtr))
             0
             (cw ^. cwTiles)
     bufferPokedVBO (rdata ^. floorVBO) nfloorvxs

src/Preload/Render.hs

@@ -5,6 +5,7 @@ module Preload.Render (
     cleanUpRenderPreload,
 ) where
 
+import Control.Concurrent
 import Shader.AuxAddition
 import Shape.Data
 import GLHelp
@@ -34,6 +35,8 @@ preloadRender = do
     glNamedBufferData theUBO 64 nullPtr GL_STREAM_DRAW
     glBindBufferBase GL_UNIFORM_BUFFER 0 theUBO
 
+    getNumCapabilities >>= print
+    
 --    orthonormalUBO <- mglCreate glCreateBuffers
 --    withArray idMat $ \ptr ->
 --        glNamedBufferStorage orthonormalUBO 64 ptr 0