This commit is contained in:
nek0 2019-10-28 18:20:34 +01:00
parent 42126a972d
commit 7f1de2ae15
14 changed files with 140 additions and 43 deletions

View file

@ -1,3 +1,4 @@
packages: packages:
./ ./
../affection
profiling: True profiling: True

View file

@ -7,6 +7,7 @@ import qualified Data.Matrix as M
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe import Data.Maybe
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.String
import Linear (V2(..)) import Linear (V2(..))
@ -77,8 +78,12 @@ buildHallFloorIO fc progress increment = do
( p + increment ( p + increment
, "Assigned room clearances" , "Assigned room clearances"
))) )))
A.logIO A.Debug ("length accessGraph: " ++ show (length accessGraph)) A.logIO
A.logIO A.Debug ("length doorgraph: " ++ show (length doorgraph)) A.Debug
("length accessGraph: " <> fromString (show $ length accessGraph))
A.logIO
A.Debug
("length doorgraph: " <> fromString (show $ length doorgraph))
return (facils, accessGraph) return (facils, accessGraph)
emptyFloor :: FloorConfig -> Matrix TileState emptyFloor :: FloorConfig -> Matrix TileState

View file

@ -12,6 +12,7 @@ import Codec.Picture.Extra
import Control.Concurrent.STM import Control.Concurrent.STM
import Data.String
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.ByteString.Lazy (toStrict) import Data.ByteString.Lazy (toStrict)
@ -62,7 +63,7 @@ loadPlayerSprite fp w h nvg rids = do
eimg <- readImage fp eimg <- readImage fp
case eimg of case eimg of
Left err -> do Left err -> do
logIO Error err logIO Error (fromString err)
exitFailure exitFailure
Right dimg -> do Right dimg -> do
let img = convertRGBA8 dimg let img = convertRGBA8 dimg
@ -73,7 +74,13 @@ loadPlayerSprite fp w h nvg rids = do
createImageMem nvg ImagePremultiplied (toStrict $ encodePng cr) createImageMem nvg ImagePremultiplied (toStrict $ encodePng cr)
case mresimg of case mresimg of
Nothing -> do Nothing -> do
logIO Error ("Failed to load: " ++ fp ++ " " ++ show i) logIO
Error
("Failed to load: " <>
fromString fp <>
" " <>
fromString (show i)
)
exitFailure exitFailure
Just resimg -> return (i, resimg) Just resimg -> return (i, resimg)
) (zip [0..] ids) ) (zip [0..] ids)

View file

@ -13,6 +13,7 @@ import qualified Data.Map as M
import qualified Data.Text as T import qualified Data.Text as T
import Data.Ecstasy import Data.Ecstasy
import Data.Maybe import Data.Maybe
import Data.String
import System.Exit (exitFailure) import System.Exit (exitFailure)
@ -40,7 +41,7 @@ loadLoad = do
(nano ud) (nano ud)
future future
progress progress
SDL.glMakeCurrent (fromJust $ window ud) (glContext ad) SDL.glMakeCurrent (fromJust $ window ud) (snd $ head $ glContext ad)
putAffection ud putAffection ud
{ stateMVar = future { stateMVar = future
, stateProgress = progress , stateProgress = progress
@ -529,7 +530,7 @@ drawLoad = do
ud <- getAffection ud <- getAffection
progress <- liftIO $ readMVar (stateProgress ud) progress <- liftIO $ readMVar (stateProgress ud)
liftIO $ do liftIO $ do
logIO A.Verbose ("LoadProgress: " ++ show progress) logIO A.Verbose ("LoadProgress: " <> fromString (show progress))
drawLoadScreen ud progress drawLoadScreen ud progress
updateLoad :: Double -> Affection UserData () updateLoad :: Double -> Affection UserData ()

View file

@ -30,15 +30,19 @@ foreign import ccall unsafe "glewInit"
main :: IO () main :: IO ()
main = do main = do
let config = AffectionConfig let config = AffectionConfig
{ initComponents = All { initComponents = All
, windowTitle = "Tracer" , windowTitle = "Tracer"
, windowConfig = SDL.defaultWindow , windowConfigs =
{ SDL.windowInitialSize = V2 1280 720 [ ( 0
, SDL.windowResizable = True , SDL.defaultWindow
, SDL.windowOpenGL = Just SDL.defaultOpenGL { SDL.windowInitialSize = V2 1280 720
{ SDL.glProfile = SDL.Core SDL.Normal 3 3 , SDL.windowResizable = True
} , SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
} { SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
)
]
, canvasSize = Nothing , canvasSize = Nothing
, preLoop = pre >> smLoad Load , preLoop = pre >> smLoad Load
, eventLoop = handle , eventLoop = handle
@ -54,8 +58,8 @@ pre :: Affection UserData ()
pre = do pre = do
ad <- A.get ad <- A.get
ud <- getAffection ud <- getAffection
threadCtx <- SDL.glCreateContext (drawWindow ad) threadCtx <- SDL.glCreateContext (snd $ head $ drawWindows ad)
SDL.glMakeCurrent (drawWindow ad) (glContext ad) SDL.glMakeCurrent (snd $ head $ drawWindows ad) (snd $ head $ glContext ad)
let Subsystems w m k j t = subsystems ud let Subsystems w m k j t = subsystems ud
_ <- partSubscribe w (fitViewport (1280/720)) _ <- partSubscribe w (fitViewport (1280/720))
_ <- partSubscribe w exitOnWindowClose _ <- partSubscribe w exitOnWindowClose
@ -65,7 +69,7 @@ pre = do
(ws, _) <- yieldSystemT (0, defStorage) (return ()) (ws, _) <- yieldSystemT (0, defStorage) (return ())
putAffection ud putAffection ud
{ threadContext = Just threadCtx { threadContext = Just threadCtx
, window = Just (drawWindow ad) , window = Just (snd $ head $ drawWindows ad)
, worldState = ws , worldState = ws
, joyUUID = u , joyUUID = u
} }
@ -83,7 +87,9 @@ quitGame (MsgKeyboardEvent _ _ SDL.Pressed False sym)
mapM_ (partUnSubscribe k) (uuid ud) mapM_ (partUnSubscribe k) (uuid ud)
mapM_ (partUnSubscribe j) (uuid ud) mapM_ (partUnSubscribe j) (uuid ud)
mapM_ (partUnSubscribe t) (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 ()) (ws, _) <- yieldSystemT (0, defStorage) (return ())
putAffection ud putAffection ud
{ worldState = ws { worldState = ws

View file

@ -11,6 +11,7 @@ import qualified Data.Text as T
import Data.List as L import Data.List as L
import Data.Ecstasy as E import Data.Ecstasy as E
import Data.Maybe import Data.Maybe
import Data.String
import NanoVG hiding (V2(..)) import NanoVG hiding (V2(..))
@ -130,7 +131,7 @@ updateMind dt = do
else [0 .. (ceiling dpc :: Int)]) else [0 .. (ceiling dpc :: Int)])
colldpos = dpos * Prelude.foldl colldpos = dpos * Prelude.foldl
(\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a (\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) (V2 1 1)
( (
concatMap concatMap

View file

@ -25,6 +25,7 @@ import Data.Ecstasy as E
import Data.Maybe import Data.Maybe
import Data.List as L import Data.List as L
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.String
import System.Random (randomRIO) import System.Random (randomRIO)
@ -159,7 +160,12 @@ loadMapFork ud ad future progress = do
, objType = Just ObjCopier , objType = Just ObjCopier
, objState = Just "idle" , 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, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Registering computers into WorldState" , "Registering computers into WorldState"
@ -180,7 +186,12 @@ loadMapFork ud ad future progress = do
, objType = Just ObjComputer , objType = Just ObjComputer
, objState = Just "off" , 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, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Registering toilets into WorldState" , "Registering toilets into WorldState"
@ -195,7 +206,12 @@ loadMapFork ud ad future progress = do
, objAccess = Just [(V2 0 (-1), dir)] , objAccess = Just [(V2 0 (-1), dir)]
, objType = Just ObjToilet , 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, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Preparing MindMap graph" , "Preparing MindMap graph"
@ -230,7 +246,9 @@ loadMapFork ud ad future progress = do
, clearanceLvl = Just 0 , clearanceLvl = Just 0
, anim = Just $ AnimState (AnimId AnimIntruder "standing" SE) 0 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, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Registering NPCs into WorldState" , "Registering NPCs into WorldState"
@ -296,7 +314,7 @@ loadMapFork ud ad future progress = do
orientation orientation
| head wall == V2 0 1 || head wall == V2 0 (-1) = NW | head wall == V2 0 1 || head wall == V2 0 (-1) = NW
| head wall == V2 1 0 || head wall == V2 (-1) 0 = NE | 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 void $ createEntity $ newEntity
{ pos = Just (fmap ((+ 0.5) . fromIntegral) door) { pos = Just (fmap ((+ 0.5) . fromIntegral) door)
, clearanceLvl = Just (V.maximum $ , clearanceLvl = Just (V.maximum $
@ -455,7 +473,7 @@ playerInteract2 (ActionMessage ActActivate _) = do
then return $ Just (otype, ostate, ent) then return $ Just (otype, ostate, ent)
else return Nothing else return Nothing
let relEnts = catMaybes mrelEnts 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)) -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc))
mapM_ (\(t, s, e) -> mapM_ (\(t, s, e) ->
setEntity e =<< objectTransition t s True e (Just pent) setEntity e =<< objectTransition t s True e (Just pent)
@ -761,7 +779,7 @@ updateMap dt = do
colldpos = dpos * Prelude.foldl colldpos = dpos * Prelude.foldl
(\acc a -> (\acc a ->
let ret = checkBoundsCollision2 pos' npos dt 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) (V2 1 1)
( (
concatMap concatMap

View file

@ -10,6 +10,7 @@ import qualified Data.Map.Strict as M
import qualified Data.Set as S import qualified Data.Set as S
import Data.List (find) import Data.List (find)
import Data.Maybe (fromJust, isJust) import Data.Maybe (fromJust, isJust)
import Data.String
-- internal imports -- internal imports
@ -29,7 +30,13 @@ loadAdjust sub contr switchBack = do
joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData () joyListener :: Affection UserData () -> JoystickMessage -> Affection UserData ()
joyListener switchBack (MsgJoystickAxis _ _ axis val) = do joyListener switchBack (MsgJoystickAxis _ _ axis val) = do
ud <- getAffection 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 let trans = translation ud
align align
| val > 0 = AxisPositive | val > 0 = AxisPositive

View file

@ -11,6 +11,7 @@ import Linear hiding (rotate, translation)
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe (isNothing, isJust) import Data.Maybe (isNothing, isJust)
import Data.String
import Control.Monad import Control.Monad
@ -49,7 +50,7 @@ joystickConnect msg = do
mjoy <- joystickAutoConnect msg mjoy <- joystickAutoConnect msg
maybe (return ()) (\joy -> do maybe (return ()) (\joy -> do
ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy 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 putAffection ud
{ controls = Joystick joy { controls = Joystick joy
, translation = JoyTranslation defaultJoyTranslation , translation = JoyTranslation defaultJoyTranslation

View file

@ -11,6 +11,7 @@ import Data.Maybe
import Data.List (find) import Data.List (find)
import Data.List.Split (splitWhen) import Data.List.Split (splitWhen)
import qualified Data.Vector as V import qualified Data.Vector as V
import Data.String
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans (lift) 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 then standStill imgmat tsmat pos' rot' ws posbounds rp
else do else do
(_, accessibles) <- lift $ yieldSystemT ws (getObject pos') (_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
liftIO $ logIO A.Verbose ("accessibles: " ++ show accessibles) liftIO $ logIO
A.Verbose
("accessibles: " <> fromString (show accessibles))
case accessibles of case accessibles of
[] -> error ("unknown reason to stop at " ++ show pos') [] -> error ("unknown reason to stop at " ++ show pos')
objects -> do objects -> do
@ -230,7 +233,7 @@ standStill imgmat tsmat pos' rot' ws posbounds rp = do
let mdir = let mdir =
pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp
(_, accessibles) <- lift $ yieldSystemT ws (getObject pos') (_, accessibles) <- lift $ yieldSystemT ws (getObject pos')
liftIO $ logIO A.Verbose ("accessibles: " ++ show accessibles) liftIO $ logIO A.Verbose ("accessibles: " <> fromString (show accessibles))
case accessibles of case accessibles of
[] -> do [] -> do
ttl <- liftIO $ randomRIO (5, 30) ttl <- liftIO $ randomRIO (5, 30)
@ -311,7 +314,7 @@ getObject npos = do
oacc <- query objAccess oacc <- query objAccess
ent <- queryEnt ent <- queryEnt
return (ent, pos', oacc) return (ent, pos', oacc)
liftIO $ logIO A.Verbose ("candidates: " ++ show candidates) liftIO $ logIO A.Verbose ("candidates: " <> fromString (show candidates))
return $ return $
filter (\(_, p, deltaors) -> filter (\(_, p, deltaors) ->
any (\(delta, _) -> fmap floor p + delta == fmap floor npos) 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) ntargeti <- randomRIO (0, V.length seekRP - 1)
let ntarget = pointCoord (seekRP V.! ntargeti) let ntarget = pointCoord (seekRP V.! ntargeti)
path = astarAppl imgmat posbounds ntarget pos' 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 case path of
Nothing -> do 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 [] putMVar mvar []
-- getPath pos' mvar rp imgmat posbounds -- getPath pos' mvar rp imgmat posbounds
Just p -> putMVar mvar (chewPath tsmat p) Just p -> putMVar mvar (chewPath tsmat p)
@ -348,10 +363,22 @@ getPathTo
-> IO () -> IO ()
getPathTo pos' mvar target imgmat tsmat posbounds = do getPathTo pos' mvar target imgmat tsmat posbounds = do
let path = astarAppl imgmat posbounds target pos' 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 case path of
Nothing -> do 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) Just p -> putMVar mvar (chewPath tsmat p)
simplifyPath :: [V2 Int] -> V2 Int -> [V2 Int] simplifyPath :: [V2 Int] -> V2 Int -> [V2 Int]

View file

@ -5,6 +5,8 @@ module Object.ActionTime where
import Affection as A import Affection as A
import Data.String
-- internal imports -- internal imports
import Types import Types
@ -17,4 +19,7 @@ instance ActionTime ObjType ObjState where
actionTime ObjComputer "hack" = 20 actionTime ObjComputer "hack" = 20
actionTime ObjDoor "open" = 2 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

View file

@ -11,6 +11,7 @@ import Control.Monad.IO.Class (MonadIO(..))
import Data.Ecstasy import Data.Ecstasy
import Data.Maybe import Data.Maybe
import Data.String
import Linear import Linear
@ -39,7 +40,7 @@ computerObjectAction dt t@ObjComputer s@"on" ent = do
mtime <- queryMaybe objStateTime mtime <- queryMaybe objStateTime
case mtime of case mtime of
Nothing -> do Nothing -> do
liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": on!") liftIO $ logIO Verbose ("Computer " <> fromString (show ent) <> ": on!")
let dur = actionTime t s let dur = actionTime t s
return unchanged return unchanged
{ objStateTime = Set dur { objStateTime = Set dur
@ -77,7 +78,9 @@ computerObjectAction dt t@ObjComputer s@"hack" ent = do
mtime <- queryMaybe objStateTime mtime <- queryMaybe objStateTime
case mtime of case mtime of
Nothing -> do Nothing -> do
liftIO $ logIO Verbose ("Computer " ++ show ent ++ ": hacking!") liftIO $ logIO
Verbose
("Computer " <> fromString (show ent) <> ": hacking!")
return unchanged return unchanged
{ objStateTime = Set (actionTime t s) { objStateTime = Set (actionTime t s)
} }

View file

@ -10,6 +10,7 @@ import Control.Monad (when)
import Data.Ecstasy import Data.Ecstasy
import Data.Maybe import Data.Maybe
import Data.String
import Linear import Linear
@ -44,11 +45,18 @@ doorObjectTransition t@ObjDoor s _ ent (Just aent) = do
dir <- query rot dir <- query rot
oclear <- query clearanceLvl oclear <- query clearanceLvl
mttl <- queryMaybe objStateTime 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) -- liftIO $ A.logIO A.Debug ("door clearance: " ++ show oclear ++ ", entity clearance: " ++ show clearance)
if clearance >= oclear if clearance >= oclear
then do then do
liftIO $ A.logIO A.Verbose ("door " ++ show ent ++ " opens") liftIO $ A.logIO
A.Verbose
("door " <> fromString (show ent) <> " opens")
let nstat = AnimState let nstat = AnimState
(AnimId AnimDoor0 "open" dir) (AnimId AnimDoor0 "open" dir)
0 0

View file

@ -10,6 +10,7 @@ import Data.ByteString.Lazy (toStrict)
import Data.Graph.AStar import Data.Graph.AStar
import Data.Maybe import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import Data.String
import Control.Monad (join, when) import Control.Monad (join, when)
@ -241,7 +242,7 @@ loadAnimationSprites fp nvg idconfs = do
eimg <- readImage fp eimg <- readImage fp
case eimg of case eimg of
Left err -> do Left err -> do
logIO Error err logIO Error (fromString err)
exitFailure exitFailure
Right dimg -> do Right dimg -> do
let img = convertRGBA8 dimg let img = convertRGBA8 dimg
@ -257,7 +258,13 @@ loadAnimationSprites fp nvg idconfs = do
crs crs
imgs <- if any isNothing mresimgs imgs <- if any isNothing mresimgs
then do then do
logIO Error ("failed to load: " ++ fp ++ " " ++ show i) logIO
Error
("failed to load: " <>
fromString fp <>
" " <>
fromString (show i)
)
exitFailure exitFailure
else else
return $ catMaybes mresimgs return $ catMaybes mresimgs