nek0/tracer
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

textify

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

1
cabal.project
View file

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

9
src/Floorplan.hs
View file

@ -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

11
src/Init.hs
View file

@ -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)

5
src/Load.hs
View file

@ -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 ()

32
src/Main.hs
View file

@ -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

3
src/MainGame/MindMap.hs
View file

@ -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

32
src/MainGame/WorldMap.hs
View file

@ -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

9
src/Menu/Adjust.hs
View file

@ -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

3
src/Menu/Connect.hs
View file

@ -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

41
src/NPC.hs
View file

@ -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]

7
src/Object/ActionTime.hs
View file

@ -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

7
src/Object/Computer.hs
View file

@ -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)
}

12
src/Object/Door.hs
View file

@ -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

11
src/Util.hs
View file

@ -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