diff --git a/cabal.project b/cabal.project index a74cef7..00222c9 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,4 @@ packages: ./ + ../affection profiling: True diff --git a/src/Floorplan.hs b/src/Floorplan.hs index a6af206..b41d76b 100644 --- a/src/Floorplan.hs +++ b/src/Floorplan.hs @@ -7,6 +7,7 @@ import qualified Data.Matrix as M import qualified Data.Text as T import Data.Maybe import qualified Data.Vector as V +import Data.String import Linear (V2(..)) @@ -77,8 +78,12 @@ buildHallFloorIO fc progress increment = do ( p + increment , "Assigned room clearances" ))) - A.logIO A.Debug ("length accessGraph: " ++ show (length accessGraph)) - A.logIO A.Debug ("length doorgraph: " ++ show (length doorgraph)) + A.logIO + A.Debug + ("length accessGraph: " <> fromString (show $ length accessGraph)) + A.logIO + A.Debug + ("length doorgraph: " <> fromString (show $ length doorgraph)) return (facils, accessGraph) emptyFloor :: FloorConfig -> Matrix TileState diff --git a/src/Init.hs b/src/Init.hs index c5181d3..18f4da4 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -12,6 +12,7 @@ import Codec.Picture.Extra import Control.Concurrent.STM +import Data.String import qualified Data.Set as S import qualified Data.Map.Strict as M import Data.ByteString.Lazy (toStrict) @@ -62,7 +63,7 @@ loadPlayerSprite fp w h nvg rids = do eimg <- readImage fp case eimg of Left err -> do - logIO Error err + logIO Error (fromString err) exitFailure Right dimg -> do let img = convertRGBA8 dimg @@ -73,7 +74,13 @@ loadPlayerSprite fp w h nvg rids = do createImageMem nvg ImagePremultiplied (toStrict $ encodePng cr) case mresimg of Nothing -> do - logIO Error ("Failed to load: " ++ fp ++ " " ++ show i) + logIO + Error + ("Failed to load: " <> + fromString fp <> + " " <> + fromString (show i) + ) exitFailure Just resimg -> return (i, resimg) ) (zip [0..] ids) diff --git a/src/Load.hs b/src/Load.hs index 67e9ac4..b1db38e 100644 --- a/src/Load.hs +++ b/src/Load.hs @@ -13,6 +13,7 @@ import qualified Data.Map as M import qualified Data.Text as T import Data.Ecstasy import Data.Maybe +import Data.String import System.Exit (exitFailure) @@ -40,7 +41,7 @@ loadLoad = do (nano ud) future progress - SDL.glMakeCurrent (fromJust $ window ud) (glContext ad) + SDL.glMakeCurrent (fromJust $ window ud) (snd $ head $ glContext ad) putAffection ud { stateMVar = future , stateProgress = progress @@ -529,7 +530,7 @@ drawLoad = do ud <- getAffection progress <- liftIO $ readMVar (stateProgress ud) liftIO $ do - logIO A.Verbose ("LoadProgress: " ++ show progress) + logIO A.Verbose ("LoadProgress: " <> fromString (show progress)) drawLoadScreen ud progress updateLoad :: Double -> Affection UserData () diff --git a/src/Main.hs b/src/Main.hs index 5fb265b..637d16f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -30,15 +30,19 @@ foreign import ccall unsafe "glewInit" main :: IO () main = do let config = AffectionConfig - { initComponents = All - , windowTitle = "Tracer" - , windowConfig = SDL.defaultWindow - { SDL.windowInitialSize = V2 1280 720 - , SDL.windowResizable = True - , SDL.windowOpenGL = Just SDL.defaultOpenGL - { SDL.glProfile = SDL.Core SDL.Normal 3 3 - } - } + { initComponents = All + , windowTitle = "Tracer" + , windowConfigs = + [ ( 0 + , SDL.defaultWindow + { SDL.windowInitialSize = V2 1280 720 + , SDL.windowResizable = True + , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 3 + } + } + ) + ] , canvasSize = Nothing , preLoop = pre >> smLoad Load , eventLoop = handle @@ -54,8 +58,8 @@ pre :: Affection UserData () pre = do ad <- A.get ud <- getAffection - threadCtx <- SDL.glCreateContext (drawWindow ad) - SDL.glMakeCurrent (drawWindow ad) (glContext ad) + threadCtx <- SDL.glCreateContext (snd $ head $ drawWindows ad) + SDL.glMakeCurrent (snd $ head $ drawWindows ad) (snd $ head $ glContext ad) let Subsystems w m k j t = subsystems ud _ <- partSubscribe w (fitViewport (1280/720)) _ <- partSubscribe w exitOnWindowClose @@ -65,7 +69,7 @@ pre = do (ws, _) <- yieldSystemT (0, defStorage) (return ()) putAffection ud { threadContext = Just threadCtx - , window = Just (drawWindow ad) + , window = Just (snd $ head $ drawWindows ad) , worldState = ws , joyUUID = u } @@ -83,7 +87,9 @@ quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym) mapM_ (partUnSubscribe k) (uuid ud) mapM_ (partUnSubscribe j) (uuid ud) mapM_ (partUnSubscribe t) (uuid ud) - SDL.glMakeCurrent (drawWindow ad) (glContext ad) + SDL.glMakeCurrent + (snd $ head $ drawWindows ad) + (snd $ head $ glContext ad) (ws, _) <- yieldSystemT (0, defStorage) (return ()) putAffection ud { worldState = ws diff --git a/src/MainGame/MindMap.hs b/src/MainGame/MindMap.hs index f88b5cf..7c360eb 100644 --- a/src/MainGame/MindMap.hs +++ b/src/MainGame/MindMap.hs @@ -11,6 +11,7 @@ import qualified Data.Text as T import Data.List as L import Data.Ecstasy as E import Data.Maybe +import Data.String import NanoVG hiding (V2(..)) @@ -130,7 +131,7 @@ updateMind dt = do else [0 .. (ceiling dpc :: Int)]) colldpos = dpos * Prelude.foldl (\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a - in A.log A.Verbose (show ret) ret) + in A.log A.Verbose (fromString $ show ret) ret) (V2 1 1) ( concatMap diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index abd6d5f..5ff8282 100644 --- a/src/MainGame/WorldMap.hs +++ b/src/MainGame/WorldMap.hs @@ -25,6 +25,7 @@ import Data.Ecstasy as E import Data.Maybe import Data.List as L import qualified Data.Vector as V +import Data.String import System.Random (randomRIO) @@ -159,7 +160,12 @@ loadMapFork ud ad future progress = do , objType = Just ObjCopier , objState = Just "idle" } - ) (A.log A.Debug ("number of copiers: " ++ show (length copiers)) copiers) + ) + (A.log + A.Debug + ("number of copiers: " <> fromString (show $ length copiers)) + copiers + ) liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Registering computers into WorldState" @@ -180,7 +186,12 @@ loadMapFork ud ad future progress = do , objType = Just ObjComputer , objState = Just "off" } - ) (A.log A.Debug ("number of computers: " ++ show (length computers)) computers) + ) + (A.log + A.Debug + ("number of computers: " <> fromString (show $ length computers)) + computers + ) liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Registering toilets into WorldState" @@ -195,7 +206,12 @@ loadMapFork ud ad future progress = do , objAccess = Just [(V2 0 (-1), dir)] , objType = Just ObjToilet } - ) (A.log A.Debug ("number of toilets: " ++ show (length toilets)) toilets) + ) + (A.log + A.Debug + ("number of toilets: " <> fromString (show $ length toilets)) + toilets + ) liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Preparing MindMap graph" @@ -230,7 +246,9 @@ loadMapFork ud ad future progress = do , clearanceLvl = Just 0 , anim = Just $ AnimState (AnimId AnimIntruder "standing" SE) 0 0 } - liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length computers) + liftIO $ A.logIO + A.Debug + ("number of placed NPCs: " <> fromString (show $ length computers)) liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Registering NPCs into WorldState" @@ -296,7 +314,7 @@ loadMapFork ud ad future progress = do orientation | head wall == V2 0 1 || head wall == V2 0 (-1) = NW | head wall == V2 1 0 || head wall == V2 (-1) 0 = NE - | otherwise = error ("strange wall: " ++ show wall) + | otherwise = error ("strange wall: " ++ show wall) void $ createEntity $ newEntity { pos = Just (fmap ((+ 0.5) . fromIntegral) door) , clearanceLvl = Just (V.maximum $ @@ -455,7 +473,7 @@ playerInteract2 (ActionMessage ActActivate _) = do then return $ Just (otype, ostate, ent) else return Nothing let relEnts = catMaybes mrelEnts - liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts) + liftIO $ A.logIO A.Debug ("relEnts: " <> fromString (show relEnts)) -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc)) mapM_ (\(t, s, e) -> setEntity e =<< objectTransition t s True e (Just pent) @@ -761,7 +779,7 @@ updateMap dt = do colldpos = dpos * Prelude.foldl (\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a - in A.log A.Verbose (show ret) ret) + in A.log A.Verbose (fromString $ show ret) ret) (V2 1 1) ( concatMap diff --git a/src/Menu/Adjust.hs b/src/Menu/Adjust.hs index 97e52ed..d2a3959 100644 --- a/src/Menu/Adjust.hs +++ b/src/Menu/Adjust.hs @@ -10,6 +10,7 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S import Data.List (find) import Data.Maybe (fromJust, isJust) +import Data.String -- internal imports @@ -29,7 +30,13 @@ loadAdjust sub contr switchBack = do joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData () joyListener switchBack (MsgJoystickAxis _ _ axis val) = do ud <- getAffection - liftIO $ logIO A.Debug ("switching " ++ show (state ud) ++ " to " ++ show axis) + liftIO $ logIO + A.Debug + ("switching " <> + fromString (show $ state ud) <> + " to " <> + fromString (show axis) + ) let trans = translation ud align | val > 0 = AxisPositive diff --git a/src/Menu/Connect.hs b/src/Menu/Connect.hs index 57a8d16..4c3bd0c 100644 --- a/src/Menu/Connect.hs +++ b/src/Menu/Connect.hs @@ -11,6 +11,7 @@ import Linear hiding (rotate, translation) import qualified Data.Set as S import qualified Data.Map.Strict as M import Data.Maybe (isNothing, isJust) +import Data.String import Control.Monad @@ -49,7 +50,7 @@ joystickConnect msg = do mjoy <- joystickAutoConnect msg maybe (return ()) (\joy -> do ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy - liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident + liftIO $ logIO A.Debug $ "Joystick connected: " <> fromString (show ident) putAffection ud { controls = Joystick joy , translation = JoyTranslation defaultJoyTranslation diff --git a/src/NPC.hs b/src/NPC.hs index 0796b83..7b83763 100644 --- a/src/NPC.hs +++ b/src/NPC.hs @@ -11,6 +11,7 @@ import Data.Maybe import Data.List (find) import Data.List.Split (splitWhen) import qualified Data.Vector as V +import Data.String import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans (lift) @@ -113,7 +114,9 @@ updateNPCs imgmat tsmat ws rrp dt = do then standStill imgmat tsmat pos' rot' ws posbounds rp else do (_, accessibles) <- lift $ yieldSystemT ws (getObject pos') - liftIO $ logIO A.Verbose ("accessibles: " ++ show accessibles) + liftIO $ logIO + A.Verbose + ("accessibles: " <> fromString (show accessibles)) case accessibles of [] -> error ("unknown reason to stop at " ++ show pos') objects -> do @@ -230,7 +233,7 @@ standStill imgmat tsmat pos' rot' ws posbounds rp = do let mdir = pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp (_, accessibles) <- lift $ yieldSystemT ws (getObject pos') - liftIO $ logIO A.Verbose ("accessibles: " ++ show accessibles) + liftIO $ logIO A.Verbose ("accessibles: " <> fromString (show accessibles)) case accessibles of [] -> do ttl <- liftIO $ randomRIO (5, 30) @@ -311,7 +314,7 @@ getObject npos = do oacc <- query objAccess ent <- queryEnt return (ent, pos', oacc) - liftIO $ logIO A.Verbose ("candidates: " ++ show candidates) + liftIO $ logIO A.Verbose ("candidates: " <> fromString (show candidates)) return $ filter (\(_, p, deltaors) -> any (\(delta, _) -> fmap floor p + delta == fmap floor npos) deltaors @@ -330,10 +333,22 @@ getPath pos' mvar rp imgmat tsmat posbounds = do ntargeti <- randomRIO (0, V.length seekRP - 1) let ntarget = pointCoord (seekRP V.! ntargeti) path = astarAppl imgmat posbounds ntarget pos' - logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget) + logIO + A.Verbose + ("seeking path from " <> + fromString (show pos') <> + " to " <> + fromString (show ntarget) + ) case path of Nothing -> do - logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show ntarget) + logIO + A.Error + ("No path from " <> + fromString (show pos') <> + " to " <> + fromString ( show ntarget) + ) putMVar mvar [] -- getPath pos' mvar rp imgmat posbounds Just p -> putMVar mvar (chewPath tsmat p) @@ -348,10 +363,22 @@ getPathTo -> IO () getPathTo pos' mvar target imgmat tsmat posbounds = do let path = astarAppl imgmat posbounds target pos' - logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show target) + logIO + A.Verbose + ("seeking path from " <> + fromString (show pos') <> + " to " <> + fromString (show target) + ) case path of Nothing -> do - logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show target) + logIO + A.Error + ("No path from " <> + fromString (show pos') <> + " to " <> + fromString (show target) + ) Just p -> putMVar mvar (chewPath tsmat p) simplifyPath :: [V2 Int] -> V2 Int -> [V2 Int] diff --git a/src/Object/ActionTime.hs b/src/Object/ActionTime.hs index 815e438..4fcdc8f 100644 --- a/src/Object/ActionTime.hs +++ b/src/Object/ActionTime.hs @@ -5,6 +5,8 @@ module Object.ActionTime where import Affection as A +import Data.String + -- internal imports import Types @@ -17,4 +19,7 @@ instance ActionTime ObjType ObjState where actionTime ObjComputer "hack" = 20 actionTime ObjDoor "open" = 2 - actionTime o s = A.log Error (show o ++ ": " ++ s ++ ": has not a time") 0 + actionTime o s = A.log + Error + (fromString (show o) <> ": " <> fromString s <> ": has not a time") + 0 diff --git a/src/Object/Computer.hs b/src/Object/Computer.hs index 0eeb8f0..5f4812a 100644 --- a/src/Object/Computer.hs +++ b/src/Object/Computer.hs @@ -11,6 +11,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Data.Ecstasy import Data.Maybe +import Data.String import Linear @@ -39,7 +40,7 @@ computerObjectAction dt t@ObjComputer s@"on" ent = do mtime <- queryMaybe objStateTime case mtime of Nothing -> do - liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": on!") + liftIO $ logIO Verbose ("Computer " <> fromString (show ent) <> ": on!") let dur = actionTime t s return unchanged { objStateTime = Set dur @@ -77,7 +78,9 @@ computerObjectAction dt t@ObjComputer s@"hack" ent = do mtime <- queryMaybe objStateTime case mtime of Nothing -> do - liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": hacking!") + liftIO $ logIO + Verbose + ("Computer " <> fromString (show ent) <> ": hacking!") return unchanged { objStateTime = Set (actionTime t s) } diff --git a/src/Object/Door.hs b/src/Object/Door.hs index f96c558..8c4a12d 100644 --- a/src/Object/Door.hs +++ b/src/Object/Door.hs @@ -10,6 +10,7 @@ import Control.Monad (when) import Data.Ecstasy import Data.Maybe +import Data.String import Linear @@ -44,11 +45,18 @@ doorObjectTransition t@ObjDoor s _ ent (Just aent) = do dir <- query rot oclear <- query clearanceLvl mttl <- queryMaybe objStateTime - liftIO $ A.logIO A.Verbose (show aent ++ " is attempting to open door " ++ show ent) + liftIO $ A.logIO + A.Verbose + (fromString (show aent) <> + " is attempting to open door " <> + fromString (show ent) + ) -- liftIO $ A.logIO A.Debug ("door clearance: " ++ show oclear ++ ", entity clearance: " ++ show clearance) if clearance >= oclear then do - liftIO $ A.logIO A.Verbose ("door " ++ show ent ++ " opens") + liftIO $ A.logIO + A.Verbose + ("door " <> fromString (show ent) <> " opens") let nstat = AnimState (AnimId AnimDoor0 "open" dir) 0 diff --git a/src/Util.hs b/src/Util.hs index 286b8f7..019e6d7 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -10,6 +10,7 @@ import Data.ByteString.Lazy (toStrict) import Data.Graph.AStar import Data.Maybe import qualified Data.Text as T +import Data.String import Control.Monad (join, when) @@ -241,7 +242,7 @@ loadAnimationSprites fp nvg idconfs = do eimg <- readImage fp case eimg of Left err -> do - logIO Error err + logIO Error (fromString err) exitFailure Right dimg -> do let img = convertRGBA8 dimg @@ -257,7 +258,13 @@ loadAnimationSprites fp nvg idconfs = do crs imgs <- if any isNothing mresimgs then do - logIO Error ("failed to load: " ++ fp ++ " " ++ show i) + logIO + Error + ("failed to load: " <> + fromString fp <> + " " <> + fromString (show i) + ) exitFailure else return $ catMaybes mresimgs