diff --git a/improviz.cabal b/improviz.cabal index ae38aa1..0b4bee1 100644 --- a/improviz.cabal +++ b/improviz.cabal @@ -51,6 +51,7 @@ executable improviz , yaml other-modules: Improviz , Improviz.Runtime + , Improviz.SystemVars , Improviz.UI , Configuration , Configuration.CLI diff --git a/improviz.yaml b/improviz.yaml index 53f6cc0..35f73f4 100644 --- a/improviz.yaml +++ b/improviz.yaml @@ -20,6 +20,7 @@ codeFiles: - "./stdlib/shapes.pz" - "./stdlib/style.pz" - "./stdlib/textures.pz" + - "./stdlib/screen.pz" - "./usercode/grid.pz" - "./usercode/seq.pz" debug: false diff --git a/src/Improviz.hs b/src/Improviz.hs index 5e1bcc7..dfdbcf0 100644 --- a/src/Improviz.hs +++ b/src/Improviz.hs @@ -74,7 +74,7 @@ createEnv config gfx = do externalVars <- newTVarIO M.empty uiState <- newTVarIO defaultUI userCode <- readExternalCode (config ^. codeFiles) - runtimeState <- makeRuntimeState userCode gfxContext >>= newTVarIO + runtimeState <- makeRuntimeState userCode gfx gfxContext >>= newTVarIO return $ ImprovizEnv runtimeState uiState gfxState diff --git a/src/Improviz/Runtime.hs b/src/Improviz/Runtime.hs index 0be0844..f7b9d26 100644 --- a/src/Improviz/Runtime.hs +++ b/src/Improviz/Runtime.hs @@ -8,11 +8,14 @@ module Improviz.Runtime , updateProgram , resetProgram , saveProgram + , resizeRuntime , programHasChanged ) where -import Language ( initialInterpreterState ) +import Language ( initialInterpreterState + , updateSystemVars + ) import Language.Ast ( Program(..) ) import Language.Interpreter.Types ( InterpreterState ) import Lens.Simple ( (^.) @@ -21,6 +24,8 @@ import Lens.Simple ( (^.) , makeLenses ) import Gfx.Context ( GfxContext ) +import Gfx.Engine ( GfxEngine ) +import qualified Improviz.SystemVars as SV data ImprovizRuntime gfxContext = ImprovizRuntime @@ -34,15 +39,28 @@ data ImprovizRuntime gfxContext = ImprovizRuntime makeLenses ''ImprovizRuntime makeRuntimeState - :: [(FilePath, Program)] -> GfxContext -> IO (ImprovizRuntime GfxContext) -makeRuntimeState userCode ctx = do - initial <- initialInterpreterState userCode ctx - return ImprovizRuntime { _programText = "" - , _lastProgramText = "" - , _currentAst = Program [] - , _lastWorkingAst = Program [] - , _initialInterpreter = initial - } + :: [(FilePath, Program)] + -> GfxEngine + -> GfxContext + -> IO (ImprovizRuntime GfxContext) +makeRuntimeState userCode gfx ctx = + let sysVars = SV.create gfx + in do + is <- initialInterpreterState sysVars userCode ctx + return ImprovizRuntime { _programText = "" + , _lastProgramText = "" + , _currentAst = Program [] + , _lastWorkingAst = Program [] + , _initialInterpreter = is + } + + +resizeRuntime + :: GfxEngine -> ImprovizRuntime GfxContext -> ImprovizRuntime GfxContext +resizeRuntime gfx runtime = + let newSysVars = SV.create gfx + interpState = _initialInterpreter runtime + in runtime { _initialInterpreter = updateSystemVars newSysVars interpState } updateProgram :: String -> Program -> ImprovizRuntime eg -> ImprovizRuntime eg updateProgram newProgram newAst = diff --git a/src/Improviz/SystemVars.hs b/src/Improviz/SystemVars.hs new file mode 100644 index 0000000..2005fba --- /dev/null +++ b/src/Improviz/SystemVars.hs @@ -0,0 +1,36 @@ +module Improviz.SystemVars where + +import Lens.Simple ( (^.) ) + +import Linear.Matrix ( (!*!) + , (!*) + , inv44 + ) +import Linear.V3 ( V3(..) ) +import Linear.V4 ( V4(..) + , point + , _x + , _y + ) + +import Gfx.Engine ( GfxEngine + , projectionMatrix + , viewMatrix + ) +import Language.Ast ( Value(..) ) + +create :: GfxEngine -> [(String, Value)] +create gfx = + let pMatrix = gfx ^. projectionMatrix + vMatrix = gfx ^. viewMatrix + iPVMatrix = inv44 (pMatrix !*! vMatrix) + V4 _ _ zVal wVal = pMatrix !* (vMatrix !* point (V3 0.0 0.0 0.0)) + screenCorner = V4 (1.0 * wVal) (1.0 * wVal) zVal wVal + cornerPos = iPVMatrix !* screenCorner + cornerX = cornerPos ^. _x + cornerY = cornerPos ^. _y + aspect = cornerX / cornerY + in [ ("aspect" , Number aspect) + , ("screenCornerX", Number cornerX) + , ("screenCornerY", Number cornerY) + ] diff --git a/src/Language.hs b/src/Language.hs index 4d82b7a..3a14f9c 100644 --- a/src/Language.hs +++ b/src/Language.hs @@ -3,6 +3,7 @@ module Language , parse , interpret , setInterpreterVariables + , updateSystemVars , module Language.Ast ) where @@ -20,6 +21,7 @@ import Language.Ast ( Identifier ) import Language.Ast.Transformers ( transform ) import Language.Interpreter ( emptyState + , setSystemVars , getGlobalNames , interpretLanguage , setGlobal @@ -28,6 +30,7 @@ import Language.Interpreter.Types ( InterpreterState , gfxContext , runInterpreterM , externals + , systemVars ) import Language.Interpreter.StdLib ( addStdLib ) import Language.Parser ( parseProgram ) @@ -39,10 +42,14 @@ parse :: String -> Either ParserError Program parse = parseProgram initialInterpreterState - :: [(FilePath, Program)] -> GfxContext -> IO InterpreterState -initialInterpreterState userCode ctx = + :: [(Identifier, Value)] + -> [(FilePath, Program)] + -> GfxContext + -> IO InterpreterState +initialInterpreterState systemVariables userCode ctx = let langState = set gfxContext ctx emptyState setup = do + setSystemVars systemVariables addStdLib globals <- getGlobalNames mapM (load globals) userCode @@ -52,6 +59,10 @@ initialInterpreterState userCode ctx = liftIO $ logInfo ("Loading " ++ fp) interpretLanguage $ transform globals code +updateSystemVars + :: [(Identifier, Value)] -> InterpreterState -> InterpreterState +updateSystemVars newSysVars = set systemVars (M.fromList newSysVars) + setInterpreterVariables :: [(Identifier, Value)] -> M.Map String Value diff --git a/src/Language/Interpreter.hs b/src/Language/Interpreter.hs index 7f0650d..7f2aab0 100644 --- a/src/Language/Interpreter.hs +++ b/src/Language/Interpreter.hs @@ -5,6 +5,8 @@ module Language.Interpreter , getGlobalNames , setVariable , setGlobal + , setSystemVars + , getSystemVar , getVariable , getExternal , interpretLanguage @@ -42,6 +44,7 @@ emptyState :: InterpreterState emptyState = InterpreterState { _variables = LS.empty , _externals = M.empty , _globals = M.empty + , _systemVars = M.empty , _builtins = M.empty , _functions = M.empty , _textureInfo = TextureInfo M.empty @@ -87,6 +90,14 @@ getGlobal name = do getGlobalNames :: InterpreterProcess (S.Set String) getGlobalNames = M.keysSet <$> use globals +setSystemVars :: [(Identifier, Value)] -> InterpreterProcess Value +setSystemVars sysVars = assign systemVars (M.fromList sysVars) >> return Null + +getSystemVar :: Identifier -> InterpreterProcess Value +getSystemVar name = do + sv <- use systemVars + return $ fromMaybe Null (M.lookup name sv) + setVariable :: Identifier -> Value -> InterpreterProcess Value setVariable name val = do v <- use variables diff --git a/src/Language/Interpreter/StdLib/Util.hs b/src/Language/Interpreter/StdLib/Util.hs index eadb0cf..a790570 100644 --- a/src/Language/Interpreter/StdLib/Util.hs +++ b/src/Language/Interpreter/StdLib/Util.hs @@ -16,6 +16,7 @@ import Lens.Simple ( use ) import Language.Ast import Language.Interpreter ( getExternal + , getSystemVar , setBuiltIn , useGfxCtx ) @@ -27,6 +28,7 @@ addUtilStdLib :: InterpreterProcess () addUtilStdLib = do setBuiltIn "isNull" isNullFunc setBuiltIn "ext" getExtFunc + setBuiltIn "sysVar" getSysVarFunc setBuiltIn "length" lengthFunc setBuiltIn "random" randomFunc setBuiltIn "randomSeed" randomSeedFunc @@ -44,6 +46,11 @@ getExtFunc args = case args of [Symbol name] -> getExternal name Null _ -> throwError "Need to provide ext with a name" +getSysVarFunc :: [Value] -> InterpreterProcess Value +getSysVarFunc args = case args of + Symbol name : _ -> getSystemVar name + _ -> throwError "Need to provide systemVar with a name" + lengthFunc :: [Value] -> InterpreterProcess Value lengthFunc args = case args of VList elems : _ -> return $ Number $ fromIntegral $ length elems diff --git a/src/Language/Interpreter/Types.hs b/src/Language/Interpreter/Types.hs index b29bace..9963808 100644 --- a/src/Language/Interpreter/Types.hs +++ b/src/Language/Interpreter/Types.hs @@ -5,6 +5,7 @@ module Language.Interpreter.Types , InterpreterState(..) , variables , externals + , systemVars , globals , builtins , functions @@ -42,6 +43,7 @@ data InterpreterState = InterpreterState { _variables :: LS.ScopeStack Identifier Value , _externals :: M.Map Identifier Value , _globals :: M.Map Identifier Value + , _systemVars :: M.Map Identifier Value , _builtins :: M.Map Identifier BuiltInFunction , _functions :: M.Map Identifier Lambda , _textureInfo :: TextureInfo diff --git a/src/Main.hs b/src/Main.hs index 55c5cf2..ae8e367 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -67,11 +67,13 @@ initApp config width height fbWidth fbHeight = do resize :: ImprovizEnv -> Int -> Int -> Int -> Int -> IO () resize env newWidth newHeight fbWidth fbHeight = - let config = env ^. I.config - gfxVar = env ^. I.graphics + let config = env ^. I.config + gfxVar = env ^. I.graphics + runtimeVar = env ^. I.runtime in do logInfo $ "Resizing to " ++ show newWidth ++ " by " ++ show newHeight logInfo $ "Framebuffer " ++ show fbWidth ++ " by " ++ show fbHeight + runtime <- readTVarIO runtimeVar engineState <- readTVarIO gfxVar newGfx <- resizeGfx engineState config @@ -79,7 +81,9 @@ resize env newWidth newHeight fbWidth fbHeight = newHeight fbWidth fbHeight + let newRuntime = IR.resizeRuntime newGfx runtime atomically $ writeTVar gfxVar newGfx + atomically $ writeTVar runtimeVar newRuntime return () display :: ImprovizEnv -> Double -> IO () diff --git a/stdlib/screen.pz b/stdlib/screen.pz new file mode 100644 index 0000000..1b96d74 --- /dev/null +++ b/stdlib/screen.pz @@ -0,0 +1,5 @@ + +func movePct(xPct, yPct) + x = sysVar(:screenCornerX) * (xPct / 100) + y = sysVar(:screenCornerY) * (yPct / 100) + move(x, y, 0) diff --git a/test/TestHelpers/GfxContext.hs b/test/TestHelpers/GfxContext.hs index 039cd6a..62a9f7a 100644 --- a/test/TestHelpers/GfxContext.hs +++ b/test/TestHelpers/GfxContext.hs @@ -36,6 +36,7 @@ createTestGfxContext gfx = GfxContext (ColourCommand $ Fill $ TextureStyle name frame) , colourStroke = \r g b a -> addAst gfx (ColourCommand $ Stroke r g b a) , noStroke = addAst gfx (ColourCommand NoStroke) + , setStrokeSize = \_ -> print "No set stroke size command" , setMaterial = \_ -> print "No set material command" , setBackground = \_ _ _ -> print "No background command" , pushScope = addAst gfx (ScopeCommand PushScope) diff --git a/test/TestHelpers/Util.hs b/test/TestHelpers/Util.hs index 74b172d..9307d7c 100644 --- a/test/TestHelpers/Util.hs +++ b/test/TestHelpers/Util.hs @@ -29,7 +29,7 @@ gfxTest program expectedGfx = case L.parse program of Left err -> assertFailure $ prettyPrintErrors err Right ast -> do (out, ctx) <- createGfxContextHelpers - interpreterState <- L.initialInterpreterState [] ctx + interpreterState <- L.initialInterpreterState [] [] ctx result <- fst <$> L.interpret interpreterState ast assertEqual "interpreter runs" (Right Null) result gfx <- getOutputGfx out @@ -39,6 +39,6 @@ resultTest :: String -> Value -> String -> Assertion resultTest program expected message = case L.parse program of Left err -> assertFailure $ prettyPrintErrors err Right ast -> do - interpreterState <- L.initialInterpreterState [] emptyGfxContext + interpreterState <- L.initialInterpreterState [] [] emptyGfxContext result <- fst <$> L.interpret interpreterState ast assertEqual message (Right expected) result