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

Correct loading of tile buffer when loading game

Browse Source
This commit is contained in:
justin
2023-03-25 22:31:28 +00:00
parent da8a2bad6e
commit acc55f8d16
9 changed files with 114 additions and 117 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appDodge/Main.hs
-5
View File
@@ -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
+4 -3
View File
@@ -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=-l
- -with-rtsopts=-N2
- -with-rtsopts=-l
- -flate-dmd-anal
- -fno-liberate-case
- -fno-state-hack
src/Dodge/Concurrent.hs
+8 -1
View File
@@ -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
+12 -14
View File
@@ -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,25 +55,22 @@ data World = World
data TimeFlowStatus
= DeathTime
{ _deathDelay :: Int }
{_deathDelay :: Int}
| NormalTimeFlow
| ScrollTimeFlow
{ _scrollSmoothing :: Int
{ _scrollSmoothing :: Int
, _reverseAmount :: Int
, _futureWorlds :: [LWorld]
, _scrollItemLocation :: Int
}
| RewindLeftClick
{ _reverseAmount :: Int
{ _reverseAmount :: Int
, _scrollItemLocation :: Int
}
| PausedTimeFlow
{ _timeFlowCharge :: Int
{ _timeFlowCharge :: Int
, _scrollItemLocation :: Int
}
-- deriving (Eq, Ord, Show, Read) --Generic, Flat)
makeLenses ''TimeFlowStatus
makeLenses ''World
src/Dodge/Default/World.hs
+53 -62
View File
@@ -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,72 +157,69 @@ defaultHUD =
}
defaultDisplayInventory :: HUDElement
defaultDisplayInventory = 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
defaultDisplayInventory =
DisplayInventory
{ _subInventory = NoSubInventory
, _diSections = defaultInvSections
}
defaultSSSExtra :: SSSExtra
defaultSSSExtra = SSSExtra
{_sssFilters = IM.fromList [(-1,mempty),(2,mempty)]
,_sssSelPos = Nothing
defaultSSSExtra =
SSSExtra
{ _sssFilters = IM.fromList [(-1, mempty), (2, mempty)]
, _sssSelPos = Nothing
}
defaultInvSections :: SelectionSections ()
defaultInvSections = SelectionSections
{ _sssSections = IM.fromDistinctAscList $ zip [-1..]
[ defaultFiltSection
, defaultInvSection
, defaultYouSection
, defaultFiltSection & ssIndent .~ 2
& ssDescriptor .~ "NEARBY"
, defaultCOSection
]
, _sssExtra = defaultSSSExtra
}
defaultInvSections =
SelectionSections
{ _sssSections =
IM.fromDistinctAscList $
zip
[-1 ..]
[ defaultFiltSection
, defaultInvSection
, defaultYouSection
, defaultFiltSection & ssIndent .~ 2
& ssDescriptor .~ "NEARBY"
, defaultCOSection
]
, _sssExtra = defaultSSSExtra
}
defaultSS :: SelectionSection a
defaultSS = SelectionSection
{ _ssItems = mempty
, _ssCursor = Nothing
, _ssMinSize = 10
, _ssOffset = 0
, _ssShownItems = []
, _ssIndent = 0
, _ssDescriptor = ""
}
defaultSS =
SelectionSection
{ _ssItems = mempty
, _ssCursor = Nothing
, _ssMinSize = 10
, _ssOffset = 0
, _ssShownItems = []
, _ssIndent = 0
, _ssDescriptor = ""
}
defaultCOSection :: SelectionSection ()
defaultCOSection = defaultSS
& ssIndent .~ 2
& ssDescriptor .~ "CLOSE OBJECTS"
defaultCOSection =
defaultSS
& ssIndent .~ 2
& ssDescriptor .~ "CLOSE OBJECTS"
defaultFiltSection :: SelectionSection a
defaultFiltSection = defaultSS
& ssIndent .~ 0
& ssDescriptor .~ "INV"
& ssMinSize .~ 0
defaultFiltSection =
defaultSS
& ssIndent .~ 0
& ssDescriptor .~ "INV"
& ssMinSize .~ 0
defaultInvSection :: SelectionSection ()
defaultInvSection = defaultSS
& ssDescriptor .~ "INVENTORY ITEMS"
defaultInvSection =
defaultSS
& ssDescriptor .~ "INVENTORY ITEMS"
defaultYouSection :: SelectionSection ()
defaultYouSection = defaultSS
-- & ssRegex .~ UnavailableRegex
& ssIndent .~ 2
& ssMinSize .~ 1
& ssDescriptor .~ "YOUR STATUS"
defaultYouSection =
defaultSS
& ssIndent .~ 2
& ssMinSize .~ 1
& ssDescriptor .~ "YOUR STATUS"
src/Dodge/Save.hs
+9 -10
View File
@@ -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
then do
cwstr <- decodeFileStrict $ saveSlotPath ss
case cwstr of
Nothing -> putStrLn "loadSaveSlot failed to read saved file" >> return removescreenlayers
Just cw -> return $ \uv -> Just $ uv & uvWorld . cWorld .~ cw
if not fExists then error "Tried to read non-existant save file"
else return ()
mcw <- decodeFileStrict $ saveSlotPath ss
flip (maybe (error "Tried to read incorrectly encoded save file")) mcw $ \cw ->
return $ \uv -> Just
$ 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
+13 -15
View File
@@ -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
. saveWorldInSlot (LevelStartSlot 0)
. (uvScreenLayers .~ [])
. (uvWorld .~ w)
. (uvIOEffects %~ (\f uv -> (uvWorld . cWorld) (postWorldLoad (pdata ^?! renderData)) uv >>= f))
return $
Just
. saveWorldInSlot (LevelStartSlot 0)
. (uvScreenLayers .~ [])
. (uvWorld .~ w)
. postUniverseLoadSideEffect
src/Dodge/WorldLoad.hs
+12 -7
View File
@@ -1,17 +1,22 @@
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
import Control.Monad
import Control.Lens
postUniverseLoadSideEffect :: Universe -> Universe
postUniverseLoadSideEffect = (uvIOEffects %~ (\f uv -> (uvWorld . cWorld) (postWorldLoad (uv ^. preloadData . renderData)) uv >>= f))
postWorldLoad :: RenderData -> CWorld -> IO CWorld
postWorldLoad rdata cw = do
nfloorvxs <- foldM (pokeTile (rdata ^. floorVBO . vboPtr))
0
(cw ^. cwTiles)
nfloorvxs <-
foldM
(pokeTile (rdata ^. floorVBO . vboPtr))
0
(cw ^. cwTiles)
bufferPokedVBO (rdata ^. floorVBO) nfloorvxs
return $ cw & numberFloorVerxs .~ nfloorvxs
src/Preload/Render.hs
+3
View File
@@ -5,6 +5,7 @@ module Preload.Render (
cleanUpRenderPreload,
) where
import Control.Concurrent
import Shader.AuxAddition
import Shape.Data
import GLHelp
@@ -33,6 +34,8 @@ preloadRender = do
theUBO <- mglCreate glCreateBuffers
glNamedBufferData theUBO 64 nullPtr GL_STREAM_DRAW
glBindBufferBase GL_UNIFORM_BUFFER 0 theUBO
getNumCapabilities >>= print
-- orthonormalUBO <- mglCreate glCreateBuffers
-- withArray idMat $ \ptr ->