work in progress on new layer/blend system (sort of works but with lo…

…ts of undesired results)

src/Action.purs

@@ -6,9 +6,7 @@ import Data.Tempo (Tempo)
 import Data.DateTime (DateTime, adjust, diff)
 import Data.Time.Duration (Seconds)
 import Data.Maybe (maybe)
-import Data.List (List(..),(:))
 import Data.Newtype (unwrap)
-import Data.Foldable (any)
 
 import Signal (Signal)
 import DefTime (DefTime(..), calculateT1)
@@ -20,14 +18,14 @@ type Action = {
   signal :: Signal,
   defTime :: DefTime,
   transition :: Transition,
-  outputs :: List Output
+  output :: Output
   }
 
 signalToAction :: Signal -> Action
-signalToAction x = { signal: x, defTime: Quant one (InSeconds zero), transition: DefaultCrossFade, outputs: Nil }
+signalToAction x = { signal: x, defTime: Quant one (InSeconds zero), transition: DefaultCrossFade, output: Audio }
 
 setOutput :: Action -> Output -> Action
-setOutput x o = x { outputs = o : x.outputs }
+setOutput x o = x { output = o }
 
 setCrossFade :: Action -> Number -> Action
 setCrossFade x t = x { transition = CrossFade (InSeconds t) }
@@ -41,5 +39,5 @@ actionToTimes tempo eTime x = Tuple t1' t2'
     t2' = unwrap (diff t2 eTime :: Seconds)
 
 actionHasVisualOutput :: Action -> Boolean
-actionHasVisualOutput a = any (\x -> x == RGB || x == RGBA) a.outputs
+actionHasVisualOutput a = a.output == RGBA || a.output == RGB || a.output == Multiply
 

src/FragmentShader.purs

@@ -4,10 +4,9 @@ import Prelude(($),pure,show,bind,discard,(<>),(>>=),(<$>),(<<<),map,(==),(&&),o
 import Data.Maybe (Maybe(..))
 import Data.List.NonEmpty (singleton,concat,fromList,zipWith,cons,head,tail,length)
 import Data.List (List(..),(:))
-import Data.List as List
 import Data.Traversable (traverse,sequence)
 import Data.Tuple (Tuple(..),fst,snd)
-import Data.Foldable (fold,intercalate,foldM,elem)
+import Data.Foldable (fold,intercalate,foldM)
 import Data.Unfoldable1 (replicate1)
 import Control.Monad.State (get,modify_)
 import Data.Map (Map,lookup)
@@ -18,10 +17,10 @@ import Data.DateTime (DateTime)
 import NonEmptyList
 import MultiMode (MultiMode(..))
 import Signal (Signal(..))
-import Action (Action,actionToTimes,actionHasVisualOutput)
+import Action (Action,actionToTimes)
 import Output (Output(..))
 import Program (Program)
-import GLSLExpr (GLSLExpr,GLSLType(..),simpleFromString,zero,dotSum,ternaryFunction,glslTypeToString,Exprs,exprsChannels,split,unsafeSwizzleX,unsafeSwizzleY,coerce)
+import GLSLExpr (GLSLExpr,GLSLType(..),simpleFromString,zero,one,dotSum,ternaryFunction,glslTypeToString,Exprs,exprsChannels,split,unsafeSwizzleX,unsafeSwizzleY,coerce,exprChannels)
 import GLSLExpr as GLSLExpr
 import GLSL (GLSL,align,alignNoExtend,assign,assignForced,swizzleX,swizzleY,swizzleZ,swizzleW,alignFloat,texture2D,textureFFT,alignVec2,alignVec3,alignVec4,alignRGBA,runGLSL,withFxys,extend,zipWithAAA,zipWithAAAA)
 
@@ -641,65 +640,74 @@ void main() {
 
 programsToGLSL :: Tempo -> Program -> Program -> GLSL GLSLExpr
 programsToGLSL tempo oldProgram newProgram = do
-  let oldActions = map onlyVideoOutputs oldProgram.actions
-  let newActions = map onlyVideoOutputs newProgram.actions
   fxy <- assignForced GLSLExpr.defaultFxy
   modify_ $ \s -> s { fxy = fxy }
-  rgbas <- traverseActions tempo newProgram.evalTime oldActions newActions -- List GLSLExpr
-  case List.head rgbas of
+  mExpr <- foldActions tempo newProgram.evalTime Nothing oldProgram.actions newProgram.actions
+  case mExpr of
     Nothing -> pure $ coerce Vec4 zero
-    Just h -> do
-      case List.tail rgbas of
-        Nothing -> pure h
-        Just t -> foldM blend h t
-
-onlyVideoOutputs :: Maybe Action -> Maybe Action
-onlyVideoOutputs Nothing = Nothing
-onlyVideoOutputs (Just x) = if actionHasVisualOutput x then Just x else Nothing
-
-traverseActions :: Tempo -> DateTime -> List (Maybe Action) -> List (Maybe Action) -> GLSL (List GLSLExpr)
-traverseActions _ _ Nil Nil = pure List.Nil
-traverseActions tempo eTime (x:xs) Nil = do
-  mh <- actionsToGLSL tempo eTime x Nothing 
-  t <- traverseActions tempo eTime xs Nil
-  case mh of
-    Just h -> pure (h : t)
-    Nothing -> pure t
-traverseActions tempo eTime Nil (y:ys) = do
-  mh <- actionsToGLSL tempo eTime Nothing y 
-  t <- traverseActions tempo eTime Nil ys
-  case mh of
-    Just h -> pure (h : t)
-    Nothing -> pure t
-traverseActions tempo eTime (x:xs) (y:ys) = do
-  mh <- actionsToGLSL tempo eTime x y
-  t <- traverseActions tempo eTime xs ys
-  case mh of
-    Just h -> pure (h : t)
-    Nothing -> pure t
+    Just expr -> do
+      case exprChannels expr of
+        3 -> pure $ GLSLExpr.vec4binary expr one
+        _ -> pure expr
+
+foldActions :: Tempo -> DateTime -> Maybe GLSLExpr -> List (Maybe Action) -> List (Maybe Action) -> GLSL (Maybe GLSLExpr)
+foldActions _ _ prevOutputExpr _ Nil = pure prevOutputExpr
+foldActions tempo eTime prevOutputExpr Nil (y:ys) = do
+  mExpr <- appendActions tempo eTime prevOutputExpr Nothing y 
+  foldActions tempo eTime mExpr Nil ys
+foldActions tempo eTime prevOutputExpr (x:xs) (y:ys) = do
+  mExpr <- appendActions tempo eTime prevOutputExpr x y
+  foldActions tempo eTime mExpr xs ys
 
-actionsToGLSL :: Tempo -> DateTime -> Maybe Action -> Maybe Action -> GLSL (Maybe GLSLExpr)
-actionsToGLSL _ _ Nothing Nothing = pure Nothing
-actionsToGLSL tempo eTime Nothing (Just new) = do
-  rgba <- actionToGLSL new
-  let Tuple t0 t1 = actionToTimes tempo eTime new
-  Just <$> assignForced (GLSLExpr.product rgba $ GLSLExpr.fadeIn t0 t1)
-actionsToGLSL tempo eTime (Just old) Nothing = do
-  rgba <- actionToGLSL old
-  let Tuple t0 t1 = actionToTimes tempo eTime old
-  Just <$> assignForced (GLSLExpr.product rgba $ GLSLExpr.fadeOut t0 t1)
-actionsToGLSL tempo eTime (Just old) (Just new) = do
-  case old == new of
-    true -> Just <$> (actionToGLSL new >>= assignForced)
-    false -> do
-      rgbaOld <- actionToGLSL old
-      rgbaNew <- actionToGLSL new
-      let Tuple t0 t1 = actionToTimes tempo eTime new
-      rgbaOld' <- assignForced (GLSLExpr.product rgbaOld $ GLSLExpr.fadeOut t0 t1)
-      rgbaNew' <- assignForced (GLSLExpr.product rgbaNew $ GLSLExpr.fadeIn t0 t1)
-      Just <$> assignForced (GLSLExpr.sum rgbaOld' rgbaNew')
+appendActions :: Tempo -> DateTime -> Maybe GLSLExpr -> Maybe Action -> Maybe Action -> GLSL (Maybe GLSLExpr)
+appendActions _ _ prevOutputExpr _ Nothing = pure prevOutputExpr
+appendActions tempo eTime prevOutputExpr mOldAction (Just newAction) = do
+  mNewExpr <- actionToGLSL newAction.output newAction
+  case mNewExpr of 
+    Nothing -> pure prevOutputExpr
+    Just newExpr -> do
+      let Tuple t0 t1 = actionToTimes tempo eTime newAction
+      newExpr' <- assignForced $ GLSLExpr.product newExpr $ GLSLExpr.fadeIn t0 t1
+      case mOldAction of
+        Nothing -> appendExpr newAction.output prevOutputExpr newExpr'
+        Just oldAction -> do
+          mOldExpr <- actionToGLSL newAction.output oldAction
+          case mOldExpr of
+            Nothing -> appendExpr newAction.output prevOutputExpr newExpr'
+            Just oldExpr -> do
+              oldExpr' <- assignForced $ GLSLExpr.product oldExpr $ GLSLExpr.fadeOut t0 t1
+              expr <- assignForced (GLSLExpr.sum newExpr' oldExpr')
+              appendExpr newAction.output prevOutputExpr expr
+
+actionToGLSL :: Output -> Action -> GLSL (Maybe GLSLExpr)
+actionToGLSL Audio _ = pure Nothing
+actionToGLSL RGBA a = do
+  xs <- signalToGLSL Vec4 a.signal >>= alignRGBA
+  Just <$> foldM (\x y -> blend x y >>= assignForced) (head xs) (tail xs)
+actionToGLSL _ a = do
+  xs <- signalToGLSL Vec3 a.signal >>= alignVec3
+  Just <$> foldM (\x y -> assignForced $ GLSLExpr.sum x y) (head xs) (tail xs)
+
+
+appendExpr :: Output -> Maybe GLSLExpr -> GLSLExpr -> GLSL (Maybe GLSLExpr)
+appendExpr Audio x _ = pure x
+appendExpr RGBA Nothing x = pure $ Just x
+appendExpr RGBA (Just prevExpr) x = do
+  let prevRGBA = case GLSLExpr.exprChannels prevExpr of
+                   3 -> GLSLExpr.vec4binary prevExpr (GLSLExpr.float 1.0)
+                   _ -> prevExpr
+  Just <$> (blend prevRGBA x >>= assignForced)
+appendExpr RGB Nothing x = pure $ Just x
+appendExpr RGB (Just prevExpr) x = do
+  let prevRGB = GLSLExpr.coerceVec3 prevExpr -- discards previous alpha channel if there was one
+  Just <$> (assignForced $ GLSLExpr.sum prevRGB x)
+appendExpr Multiply Nothing x = pure $ Just x
+appendExpr Multiply (Just prevExpr) x = do
+  let prevRGB = GLSLExpr.coerceVec3 prevExpr -- discards previous alpha channel if there was one
+  Just <$> (assignForced $ GLSLExpr.product prevRGB x)
+
 
-actionToGLSL :: Action -> GLSL GLSLExpr
+{- actionToGLSL :: Action -> GLSL GLSLExpr
 actionToGLSL x = do
   case elem RGBA x.outputs of
     true -> signalToGLSL Vec4 x.signal >>= exprsRGBAToRGBA
@@ -717,6 +725,7 @@ exprsRGBAToRGBA xs = do
   case fromList (tail xs') of
     Nothing -> pure $ head xs'
     Just t -> foldM blend (head xs') t
+-}
 
 fragmentShader :: Boolean -> Tempo -> Map String Int -> Map String Int -> Program -> Program -> String
 fragmentShader webGl2 tempo imgMap vidMap oldProgram newProgram = header <> assignments <> gl_FragColor <> "}"

src/Output.purs

@@ -7,9 +7,11 @@ import Data.Show.Generic (genericShow)
 data Output =
   Audio |
   RGBA |
-  RGB
+  RGB |
+  Multiply
 
 derive instance Eq Output
 derive instance Generic Output _
 instance Show Output where
   show = genericShow
+

src/Parser.purs

@@ -265,6 +265,7 @@ parseReserved p "delay" = lift $ numberSignalSignalSignal p Delay
 parseReserved p "audio" = pure $ ValueOutput p Audio
 parseReserved p "rgba" = pure $ ValueOutput p RGBA
 parseReserved p "rgb" = pure $ ValueOutput p RGB
+parseReserved p "multiply" = pure $ ValueOutput p Multiply
 parseReserved p x = throwError $ ParseError ("internal error in Punctual: parseReserved called with unknown reserved word " <> x) p
 
 parseOperator :: Position -> String -> P Value

src/TokenParser.purs

@@ -34,7 +34,7 @@ boolean = choice [
 reservedNamesDef :: Array String
 reservedNamesDef = [
   "if","then","else",
-  "audio","rgba","rgb",
+  "audio","rgba","rgb","multiply",
   "pi","audioin","cps","time","beat","etime","ebeat","rnd",
   "fx","fy","fxy","px","py","pxy","frt","fr","ft","aspect",
   "lo","mid","hi","ilo","imid","ihi","fft","ifft",
@@ -44,7 +44,7 @@ reservedNamesDef = [
   "sqrt","tan","tanh","trunc",
   "rtxy","rtx","rty","xyrt","xyr","xyt","zero","zer0","bipolar","unipolar",
   "osc","tri","saw","sqr","lftri","lfsaw","lfsqr",
-  "mono","cpsmidi","midicps","dbamp","ampdb","blend",
+  "mono","cpsmidi","midicps","dbamp","ampdb",
   "hsvrgb","hsvh","hsvs","hsvv","hsvr","hsvg","hsvb",
   "rgbhsv","rgbh","rgbs","rgbv","rgbr","rgbg","rgbb",
   "dist","prox",

src/WebGL.purs

@@ -160,11 +160,11 @@ drawWebGL webGL now = do
   bindTexture glc shader ft 0 "f"
   programInfo <- read webGL.programInfo
   when (programInfo.fft == Disj true) $ do
-    _fftToTexture glc.gl webGL.sharedResources.outputAnalyser.analyserArray webGL.fftTexture
     bindTexture glc shader webGL.fftTexture 1 "o"
+    _fftToTexture glc.gl webGL.sharedResources.outputAnalyser.analyserArray webGL.fftTexture
   when (programInfo.ifft == Disj true) $ do
-    _fftToTexture glc.gl webGL.sharedResources.inputAnalyser.analyserArray webGL.ifftTexture
     bindTexture glc shader webGL.ifftTexture 2 "i"
+    _fftToTexture glc.gl webGL.sharedResources.inputAnalyser.analyserArray webGL.ifftTexture
   updateWebcamTexture webGL.sharedResources glc
   bindTexture glc shader glc.webcamTexture 3 "w"