Merge branch 'origin-selection'

improviz.cabal

@@ -51,6 +51,7 @@ executable improviz
                      , yaml
   other-modules:       Improviz
                      , Improviz.Runtime
+                     , Improviz.SystemVars
                      , Improviz.UI
                      , Configuration
                      , Configuration.CLI

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

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

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 =

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)
+      ]

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

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

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

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

src/Main.hs

@@ -67,19 +67,23 @@ 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
                                  newWidth
                                  newHeight
                                  fbWidth
                                  fbHeight
+        let newRuntime = IR.resizeRuntime newGfx runtime
         atomically $ writeTVar gfxVar newGfx
+        atomically $ writeTVar runtimeVar newRuntime
         return ()
 
 display :: ImprovizEnv -> Double -> IO ()

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)

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)

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