First main working (but not doing anything).

diff --git a/CLOC.md b/CLOC.md
index b7ef92faa52ebf8a59990a2a0863d67d14c7bf74..e4c94234277d49399a8dbac4bbb19bb28c5ffdf0 100644 (file)
--- a/CLOC.md
+++ b/CLOC.md
@@ -1,9 +1,9 @@
 
-cloc|https://github.com/AlDanial/cloc v 1.66  T=0.06 s (419.0 files/s, 27927.6 lines/s)
+cloc|https://github.com/AlDanial/cloc v 1.66  T=0.05 s (517.5 files/s, 35624.7 lines/s)
 --- | ---
 
 Language|files|blank|comment|code
 :-------|-------:|-------:|-------:|-------:
-Haskell|26|291|399|1043
+Haskell|26|302|384|1104
 --------|--------|--------|--------|--------
-SUM:|26|291|399|1043
+SUM:|26|302|384|1104

diff --git a/RCMA/Layer/Board.hs b/RCMA/Layer/Board.hs
index 8c530647f0bdb56d4a27579acb27cf9c6e856f34..0bc12240e71bef05babc19f2a2994c42166b56b8 100644 (file)
--- a/RCMA/Layer/Board.hs
+++ b/RCMA/Layer/Board.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE Arrows, FlexibleContexts #-}
 
-module RCMA.Layer.Board where
+module RCMA.Layer.Board ( boardSetup
+                        ) where
 
 import Control.Concurrent
 import Data.ReactiveValue
@@ -44,11 +45,11 @@ boardSF board = boardSF'' board []
         boardSF'' board ph = switch (splitE ^<< fmap swap ^<< boardSF' board ph)
                              (\nph -> boardSF'' board nph)
 
-boardInit :: Board
-          -> ReactiveFieldReadWrite IO Tempo
-          -> ReactiveFieldReadWrite IO Layer
-          -> IO (ReactiveFieldRead IO [Note])
-boardInit board tempoRV layerRV = do
+boardSetup :: Board
+           -> ReactiveFieldReadWrite IO Tempo
+           -> ReactiveFieldReadWrite IO Layer
+           -> IO (ReactiveFieldRead IO [Note])
+boardSetup board tempoRV layerRV = do
   layer <- reactiveValueRead layerRV
   tempo <- reactiveValueRead tempoRV
   (inBoard, outBoard) <- yampaReactiveDual (layer, tempo) (boardSF board)

diff --git a/RCMA/Main.hs b/RCMA/Main.hs
index 9a75eca5db92b169fba6035c4b4e81dc9d8e174d..4eaa5f121cb796f754532dc467e2bfc6bfea4811 100644 (file)
--- a/RCMA/Main.hs
+++ b/RCMA/Main.hs
@@ -1,13 +1,74 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Main where
 
+import Control.Concurrent
+import Data.ReactiveValue
 import FRP.Yampa
 import Hails.Yampa
+import RCMA.Layer.Board
+import RCMA.Layer.Layer
 import RCMA.Semantics
 import RCMA.Translator.Jack
 import RCMA.Translator.Message
 import RCMA.Translator.Translator
 
+import Control.Monad
+import Data.Ratio
+
+board =
+    makeBoard [((0,0),  mkCell (ChDir False na1 N)),
+               ((0,1),  mkCell (ChDir False na1 SE)),
+               ((1,1),  mkCell (Split na1)),
+               ((1,-1), mkCell (Split na1)),
+               ((-1,0), mkCell (ChDir False na2 NE))]
+
+na1 = NoteAttr {
+          naArt = Accent13,
+          naDur = 1 % 4,
+          naOrn = Ornaments Nothing [] NoSlide
+      }
+
+na2 = NoteAttr {
+          naArt = NoAccent,
+          naDur = 1 % 16,
+          naOrn = Ornaments Nothing [(10, MIDICVRnd)] SlideUp
+      }
+
+na3 = NoteAttr {
+          naArt = Accent13,
+          naDur = 0,
+          naOrn = Ornaments Nothing [] NoSlide
+      }
+
+
+bpb :: Int
+bpb = 4
+
+tempoRV :: ReactiveFieldReadWrite IO Tempo
+tempoRV = ReactiveFieldReadWrite (\_ -> return ()) (return 96) (\_ -> return ())
+
+waitForChildren :: MVar [MVar ()] -> IO ()
+waitForChildren children = do
+  cs <- takeMVar children
+  case cs of
+    []   -> return ()
+    m:ms -> do
+      putMVar children ms
+      takeMVar m
+      waitForChildren children
+
 main :: IO ()
 main = do
-  (inp, out) <- yampaReactiveDual [] rcma
-  return ()
+  (children :: MVar [MVar ()]) <- newMVar []
+  let forkChild :: IO () -> IO ThreadId
+      forkChild io = do
+        mvar <- newEmptyMVar
+        childs <- takeMVar children
+        putMVar children (mvar:childs)
+        forkFinally io (\_ -> putMVar mvar ())
+
+  layerRV <- getDefaultLayerRV
+  boardInRV <- boardSetup board tempoRV layerRV
+  jackT <- forkChild $ jackSetup (liftR2 (\t n -> (t, 0, n)) tempoRV boardInRV)
+  waitForChildren children

diff --git a/RCMA/Translator/Jack.hs b/RCMA/Translator/Jack.hs
index 0f86175bc1550b567c13d0f24b5a55e5b4b9092a..5ae01cb0ddc344609c6f6766fe4500b832229483 100644 (file)
--- a/RCMA/Translator/Jack.hs
+++ b/RCMA/Translator/Jack.hs
@@ -34,7 +34,7 @@ outPortName = "output"
 
 -- Starts a default client with an input and an output port. Doesn't
 -- do anything as such.
-jackSetup :: ReactiveFieldRead IO (LTempo, Int, [(Frames, RawMessage)])
+jackSetup :: ReactiveFieldRead IO (LTempo, Int, [Note])
           -> IO ()
 jackSetup boardInRV = Jack.handleExceptions $ do
   toProcessRV <- Trans.lift $ toProcess <$> newCBMVar []
@@ -65,7 +65,7 @@ jackCallBack :: Jack.Client
              -> JMIDI.Port Jack.Input
              -> JMIDI.Port Jack.Output
              -> ReactiveFieldReadWrite IO [(Frames, RawMessage)]
-             -> ReactiveFieldRead IO (LTempo, Int, [(Frames, RawMessage)])
+             -> ReactiveFieldRead IO (LTempo, Int, [Note])
              -> Jack.NFrames
              -> Sync.ExceptionalT E.Errno IO ()
 jackCallBack client input output toProcessRV boardInRV
@@ -79,23 +79,22 @@ jackCallBack client input output toProcessRV boardInRV
   (Jack.NFrames lframeInt) <- Trans.lift $ Jack.lastFrameTime client
   -- We write the content of the input buffer to the input of a
   -- translation signal function.
-  -- /!\ Should be moved elsewhere
+  -- /!\ Should maybe be moved elsewhere
   (inRaw, outPure) <- Trans.lift $ yampaReactiveDual [] readMessages
   Trans.lift (inMIDIRV =:> inRaw)
   (tempo, chan, boardIn') <- Trans.lift $ reactiveValueRead boardInRV
-  let boardIn = ([],[],boardIn')
+  let boardIn = (zip (repeat 0) boardIn',[],[])
   outMIDI <- Trans.lift $ reactiveValueRead outPure
   -- We translate all signals to be sent into low level signals and
   -- write them to the output buffer.
   (inPure, outRaw) <- Trans.lift $ yampaReactiveDual
                       (defaultTempo, sr, chan, ([],[],[])) gatherMessages
   -- This should all go in its own IO action
-  Trans.lift $ reactiveValueWrite inPure
-               (tempo, sr, chan, (boardIn `mappend` outMIDI))
-  Trans.lift (reactiveValueRead outRaw <**>
-              (mappend <$> reactiveValueRead toProcessRV) >>=
-              reactiveValueWrite toProcessRV)
   Trans.lift $ do
+    reactiveValueWrite inPure (tempo, sr, chan, (boardIn `mappend` outMIDI))
+    reactiveValueRead outRaw <**>
+      (mappend <$> reactiveValueRead toProcessRV) >>=
+      reactiveValueWrite toProcessRV
     (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
     let old = map (BF.first (+ (- nframesInt))) old'
     reactiveValueWrite outMIDIRV go