diff --git a/appDodge/Main.hs b/appDodge/Main.hs index 5558fc62f..9c4a65a7c 100644 --- a/appDodge/Main.hs +++ b/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) diff --git a/package.yaml b/package.yaml index 29115cdac..18843227d 100644 --- a/package.yaml +++ b/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=-l + - -with-rtsopts=-N2 + - -with-rtsopts=-l - -flate-dmd-anal - -fno-liberate-case - -fno-state-hack diff --git a/src/Dodge/Concurrent.hs b/src/Dodge/Concurrent.hs index 39122d2b9..7f0ae44fc 100644 --- a/src/Dodge/Concurrent.hs +++ b/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 diff --git a/src/Dodge/Data/World.hs b/src/Dodge/Data/World.hs index 5af719f83..3e4867e05 100644 --- a/src/Dodge/Data/World.hs +++ b/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,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 diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index a4ff77725..acd7b3a08 100644 --- a/src/Dodge/Default/World.hs +++ b/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,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" diff --git a/src/Dodge/Save.hs b/src/Dodge/Save.hs index 2684c745f..5ed66711c 100644 --- a/src/Dodge/Save.hs +++ b/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 - 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 diff --git a/src/Dodge/StartNewGame.hs b/src/Dodge/StartNewGame.hs index 88cac002e..80643bade 100644 --- a/src/Dodge/StartNewGame.hs +++ b/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 - . 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 diff --git a/src/Dodge/WorldLoad.hs b/src/Dodge/WorldLoad.hs index 62acb8eb3..4dc3c91b6 100644 --- a/src/Dodge/WorldLoad.hs +++ b/src/Dodge/WorldLoad.hs @@ -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 diff --git a/src/Preload/Render.hs b/src/Preload/Render.hs index 846d0c0fc..9553af93e 100644 --- a/src/Preload/Render.hs +++ b/src/Preload/Render.hs @@ -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 ->