From 9f1a04d70dd78d5152cfecba851d8d8a03b32128 Mon Sep 17 00:00:00 2001
From: Guerric Chupin <guerric.chupin@ensta-paristech.fr>
Date: Wed, 18 May 2016 15:55:04 +0100
Subject: [PATCH] Reactogon output unabled correctly.
---
Reactogon/Arpeggiated.hs | 8 ++---
Reactogon/Reactogon.hs | 73 +++++++++++++++++++++++++++++++---------
tmp/Melody.hs | 3 +-
3 files changed, 63 insertions(+), 21 deletions(-)
diff --git a/Reactogon/Arpeggiated.hs b/Reactogon/Arpeggiated.hs
index 69662fd..8ecf1be 100644
--- a/Reactogon/Arpeggiated.hs
+++ b/Reactogon/Arpeggiated.hs
@@ -9,11 +9,11 @@ import Note
arpeggiated :: SF (ControllerValue, Event Note) (Event Note)
arpeggiated = proc (c,n) -> do
- non <- uncurry gate ^<< identity &&& arr (event False isOn) -< n
- non' <- fmap majorThird ^<< delayEvent t -< non
- non'' <- fmap perfectFifth ^<< delayEvent t -< non'
+ non <- uncurry gate ^<< identity &&& arr (event False isOn) -< n
+ non' <- fmap majorThird ^<< delayEvent t -< non
+ non'' <- fmap perfectFifth ^<< delayEvent t -< non'
(nof',
- nof'') <- makeOff *** makeOff -< (non',non'')
+ nof'') <- makeOff *** makeOff -< (non',non'')
-- It's assumed that the NoteOff event corresponding to n will be
-- emitted.
returnA -< mergeEvents [n, non, non', nof', non'', nof'']
diff --git a/Reactogon/Reactogon.hs b/Reactogon/Reactogon.hs
index 6c43e24..2656ba6 100644
--- a/Reactogon/Reactogon.hs
+++ b/Reactogon/Reactogon.hs
@@ -5,11 +5,14 @@ import qualified MIDI as React
import qualified Sound.JACK as Jack
import qualified Sound.MIDI.Message as MIDI
import qualified Sound.JACK.MIDI as JMIDI
+{-
import Data.IORef ( IORef
, newIORef
, readIORef
, writeIORef
)
+-}
+import Control.Concurrent
import qualified Foreign.C.Error as E
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Absolute.TimeBody as EventListAbs
@@ -17,8 +20,26 @@ import qualified Data.EventList.Relative.TimeMixed as EventListTM
import qualified Control.Monad.Exception.Synchronous as Sync
import qualified Control.Monad.Trans.Class as Trans
-eventLoop :: [(Jack.NFrames,MIDI.T)]
-eventLoop = []
+import qualified Sound.MIDI.Message.Channel as Channel
+import qualified Sound.MIDI.Message.Channel.Voice as Voice
+import qualified Sound.MIDI.Message.Class.Construct as MidiCons
+
+import FRP.Yampa
+
+import Debug.Trace
+
+-- | List of absolute times (at which events should occur) and events.
+-- We assume that the list is sorted.
+outLoop :: [(Time,MIDI.T)]
+outLoop = concat [[(t,MIDI.Channel $ Channel.Cons
+ { Channel.messageChannel = Channel.toChannel 4
+ , Channel.messageBody =
+ Channel.Voice $ Voice.NoteOn (Voice.toPitch 60) (Voice.toVelocity 100)
+ }),(t+0.5,MIDI.Channel $ Channel.Cons
+ { Channel.messageChannel = Channel.toChannel 4
+ , Channel.messageBody =
+ Channel.Voice $ Voice.NoteOff (Voice.toPitch 60) (Voice.toVelocity 100)
+ })] | t <- [0,2..]]
reactogonName :: String
reactogonName = "Reactogon"
@@ -33,33 +54,53 @@ fsPortName :: String
fsPortName = "fluidsynth:midi"
main = do
- stateRef <- newIORef eventLoop
+ stateRef <- newMVar outLoop
Jack.handleExceptions $
Jack.withClientDefault reactogonName $ \client ->
Jack.withPort client outPortName $ \output -> do
Jack.withProcess client (process client stateRef output) $
Jack.withActivation client $ do
- Jack.connect client (reactogonName ++ ":" ++ outPortName) fsPortName
- Trans.lift $ putStrLn $ "Started " ++ reactogonName
- Trans.lift $ Jack.waitForBreak
+ Jack.connect client (reactogonName ++ ":" ++ outPortName) fsPortName
+ Trans.lift $ putStrLn $ "Started " ++ reactogonName
+ Trans.lift $ Jack.waitForBreak
process ::
Jack.Client ->
- IORef [(Jack.NFrames,MIDI.T)] ->
+ MVar [(Time,MIDI.T)] ->
JMIDI.Port Jack.Output ->
Jack.NFrames ->
Sync.ExceptionalT E.Errno IO ()
-process client stateRef output nframes@(Jack.NFrames nframesInt) = do
- rate <- Trans.lift $ Jack.getSampleRate client
- events <- Trans.lift $ readIORef stateRef
- let (processableEvents, futureEvents) =
- break (\(Jack.NFrames n,_) ->
- n < floor (fromIntegral nframesInt / fromIntegral rate)) events
- Trans.lift $ writeIORef stateRef futureEvents
- if null processableEvents
- then Trans.lift $ putStrLn "No events in queue."
+process client stateRef output nframes@(Jack.NFrames nframesInt) =
+ do
+ rate <- Trans.lift $ Jack.getSampleRate client
+ events <- Trans.lift $ takeMVar stateRef
+ lframe <- Trans.lift $ Jack.lastFrameTime client
+ let rateD = fromIntegral rate
+ (Jack.NFrames lframeInt) = lframe
+ currentTime = fromIntegral lframeInt / rateD
+ playableEvents = filter
+ (\(t,_) -> t - currentTime > - fromIntegral nframesInt / rateD) events
+ (processableEvents, futureEvents) = break ((> currentTime) . fst) $
+ playableEvents
+ Trans.lift $ print currentTime
+ Trans.lift $ putMVar stateRef futureEvents
+ if null processableEvents
+ then Trans.lift $ putStrLn "No events in queue."
+ else Trans.lift $ putStrLn "Event!"
+ let firstEventTime = fst $ head processableEvents
+ Trans.lift $ print $ map ((* rateD) . smartSub currentTime . fst) processableEvents
+ JMIDI.writeEventsToPort output nframes $
+ EventListAbs.fromPairList $
+ map (\(t,e) -> (Jack.NFrames $ floor $ rateD * smartSub t currentTime, e))
+ processableEvents
+
+
+smartSub x y = if x < y then y - x else x - y
+
+{-
else JMIDI.writeEventsToPort output nframes $
EventListAbs.mapTime Jack.NFrames $
EventList.toAbsoluteEventList 0 $
EventList.mapTime (\(Jack.NFrames n) -> n) $
EventList.fromPairList processableEvents
+-}
diff --git a/tmp/Melody.hs b/tmp/Melody.hs
index 5f00da2..f792957 100644
--- a/tmp/Melody.hs
+++ b/tmp/Melody.hs
@@ -24,6 +24,7 @@ import qualified Foreign.C.Error as E
import System.Environment (getProgName)
+import Debug.Trace
scale :: [Channel.Pitch]
scale = map Channel.toPitch [60, 62, 64, 65, 67, 69, 71, 72]
@@ -60,7 +61,7 @@ main = do
Jack.withPort client "output" $ \output -> do
Jack.withProcess client (process client stateRef output) $
Jack.withActivation client $ do
- --Jack.connect client "basic:output" "Midimon:input"
+ Jack.connect client "Melody:output" "fluidsynth:midi"
Trans.lift $ putStrLn $ "started " ++ name ++ "..."
Trans.lift $ Jack.waitForBreak
--
2.49.0