From f138d0245adfd0993153bd4e88352b5415aadfa0 Mon Sep 17 00:00:00 2001
From: Guerric Chupin <guerric.chupin@ensta-paristech.fr>
Date: Thu, 19 May 2016 14:56:52 +0100
Subject: [PATCH] =?utf8?q?Reactogon=20acting=20as=20a=20simple=20=E2=80=9C?=
=?utf8?q?pass-through=E2=80=9D=20MIDI=20device.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit
---
Reactogon/Auxiliary.hs | 9 +++-
Reactogon/ClientState.hs | 8 +++
Reactogon/MIDI.hs | 83 ++++++++++++++++++++++++------
Reactogon/Note.hs | 14 +++---
Reactogon/Reactimation.hs | 33 ++++++++++++
Reactogon/Reactogon.hs | 103 ++++++++++++++++++++++----------------
Reactogon/Shared.hs | 30 +++++++++++
7 files changed, 213 insertions(+), 67 deletions(-)
create mode 100644 Reactogon/ClientState.hs
create mode 100644 Reactogon/Reactimation.hs
create mode 100644 Reactogon/Shared.hs
diff --git a/Reactogon/Auxiliary.hs b/Reactogon/Auxiliary.hs
index 72ba4e5..c440774 100644
--- a/Reactogon/Auxiliary.hs
+++ b/Reactogon/Auxiliary.hs
@@ -1,7 +1,14 @@
-module Auxiliary ( dupl
+module Auxiliary ( breakMap
)where
import Control.Arrow
+import Data.Map (Map)
+import qualified Data.Map as M
dupl :: (Arrow a) => a b c -> a (b,b) (c,c)
dupl f = f *** f
+
+breakMap :: (Ord k) => k -> Map k a -> (Map k a, Map k a)
+breakMap k m = (smaller, larger')
+ where (smaller, maybeValue, larger) = M.splitLookup k m
+ larger' = maybe larger (\v -> M.insert k v larger) maybeValue
diff --git a/Reactogon/ClientState.hs b/Reactogon/ClientState.hs
new file mode 100644
index 0000000..a38e740
--- /dev/null
+++ b/Reactogon/ClientState.hs
@@ -0,0 +1,8 @@
+module ClientState where
+
+import Sound.JACK ( NFrames
+ )
+
+data ClientState = ClientState { rate :: Int
+ , buffSize :: NFrames
+ }
diff --git a/Reactogon/MIDI.hs b/Reactogon/MIDI.hs
index e9d2f94..6e15d76 100644
--- a/Reactogon/MIDI.hs
+++ b/Reactogon/MIDI.hs
@@ -1,52 +1,105 @@
-module MIDI ( SampleRate
+module MIDI ( EventQueue
+ , SampleRate
, Pitch
, toPitch
, fromPitch
, fromVelocity
, toVelocity
, Velocity
- , Voice ( fromVoice
- , toVoice
- )
- , Note(..)
+ , Message ( NoteOn
+ , NoteOff
+ , Control
+ )
+ , fromRawMessage
+ , toRawMessage
, ControllerIdx
, ControllerValue
- , Control
) where
+import qualified Sound.MIDI.Message as Message
+
import Sound.MIDI.Message.Channel.Voice ( fromPitch
, toPitch
, fromVelocity
, toVelocity
)
+import qualified Sound.MIDI.Message.Channel as Channel
import qualified Sound.MIDI.Message.Channel.Voice as Voice
+import Data.Map (Map)
+import FRP.Yampa
+
+type EventQueue = Map Time Message
type SampleRate = Int
+type RawMessage = Message.T
+
+{-
+class Message a where
+ fromMessage :: RawMessage -> Maybe a
+ toMessage :: a -> RawMessage
+-}
+
+type MidiVoice = Voice.T
+
+type Channel = Channel.Channel
type Pitch = Voice.Pitch
type Velocity = Voice.Velocity
-class Voice a where
- fromVoice :: Voice.T -> Maybe a
- toVoice :: a -> Voice.T
+{-
+class (Message a) => Voice a where
+ fromVoice :: MidiVoice -> Maybe a
+ toVoice :: a -> MidiVoice
+-}
+
+type ControllerIdx = Voice.Controller
+type ControllerValue = Int
-data Note = NoteOn Pitch Velocity
- | NoteOff Pitch Velocity
+data Message = NoteOn Channel Pitch Velocity
+ | NoteOff Channel Pitch Velocity
+ | Control Channel ControllerIdx ControllerValue
deriving(Show)
+fromRawMessage :: RawMessage -> Maybe Message
+fromRawMessage (Message.Channel (Channel.Cons c
+ (Channel.Voice (Voice.NoteOn p v)))) = Just $ NoteOn c p v
+fromRawMessage (Message.Channel (Channel.Cons c
+ (Channel.Voice (Voice.NoteOff p v)))) = Just $ NoteOff c p v
+fromRawMessage _ = Nothing
+
+toRawMessage :: Message -> RawMessage
+toRawMessage (NoteOn c p v) = (Message.Channel $ Channel.Cons c
+ (Channel.Voice $ Voice.NoteOn p v))
+toRawMessage (NoteOff c p v) = (Message.Channel $ Channel.Cons c
+ (Channel.Voice $ Voice.NoteOff p v))
+
+{-
+instance Message Note where
+ fromMessage (Message.Channel (Channel.Cons c
+ (Channel.Voice (Voice.NoteOn p v)))) = Just $ NoteOn c p v
+ fromMessage (Message.Channel (Channel.Cons c
+ (Channel.Voice (Voice.NoteOff p v)))) = Just $ NoteOff c p v
+ fromMessage _ = Nothing
+ toMessage (NoteOn c p v) = (Message.Channel $ Channel.Cons c
+ (Channel.Voice $ Voice.NoteOn p v))
+ toMessage (NoteOff c p v) = (Message.Channel $ Channel.Cons c
+ (Channel.Voice $ Voice.NoteOff p v))
+{-
instance Voice Note where
fromVoice (Voice.NoteOn p v) = Just $ NoteOn p v
fromVoice (Voice.NoteOff p v) = Just $ NoteOff p v
fromVoice _ = Nothing
toVoice (NoteOn p v) = Voice.NoteOn p v
toVoice (NoteOff p v) = Voice.NoteOff p v
-
-type ControllerIdx = Voice.Controller
-type ControllerValue = Int
+-}
+-}
+{-
data Control = Control ControllerIdx ControllerValue
-
+-}
+{-
instance Voice Control where
fromVoice (Voice.Control i v) = Just $ Control i v
fromVoice _ = Nothing
toVoice (Control i v) = Voice.Control i v
+-}
diff --git a/Reactogon/Note.hs b/Reactogon/Note.hs
index 9617a6a..d5b271d 100644
--- a/Reactogon/Note.hs
+++ b/Reactogon/Note.hs
@@ -3,23 +3,23 @@ module Note where
import MIDI
isOn :: Note -> Bool
-isOn (NoteOn _ _) = True
+isOn (NoteOn _ _ _) = True
isOn _ = False
isOff :: Note -> Bool
isOff = not . isOn
changePitch :: (Pitch -> Pitch) -> Note -> Note
-changePitch f (NoteOn p v) = NoteOn (f p) v
-changePitch f (NoteOff p v) = NoteOff (f p) v
+changePitch f (NoteOn c p v) = NoteOn c (f p) v
+changePitch f (NoteOff c p v) = NoteOff c (f p) v
changeVelocity :: (Velocity -> Velocity) -> Note -> Note
-changeVelocity f (NoteOn p v) = NoteOn p (f v)
-changeVelocity f (NoteOff p v) = NoteOff p (f v)
+changeVelocity f (NoteOn c p v) = NoteOn c p (f v)
+changeVelocity f (NoteOff c p v) = NoteOff c p (f v)
switchOnOff :: Note -> Note
-switchOnOff (NoteOn p v) = NoteOff p v
-switchOnOff (NoteOff p v) = NoteOn p v
+switchOnOff (NoteOn c p v) = NoteOff c p v
+switchOnOff (NoteOff c p v) = NoteOn c p v
perfectFifth :: Note -> Note
perfectFifth = changePitch (toPitch . (+7) . fromPitch)
diff --git a/Reactogon/Reactimation.hs b/Reactogon/Reactimation.hs
new file mode 100644
index 0000000..fbe875d
--- /dev/null
+++ b/Reactogon/Reactimation.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE Arrows #-}
+
+module Reactimation where
+
+import Data.Map (Map)
+import qualified Data.Map as M
+import FRP.Yampa
+import Control.Concurrent.MVar
+
+import MIDI
+import Arpeggiated
+
+mainReact :: IO ()
+mainReact = reactimate (initialize inRef) (sensing synthRef) actuation mainSF
+
+initialize :: MVar EventQueue -> IO EventQueue
+initialize = readMVar
+
+sensing :: MVar (SynthState)
+ -> MVar (Map Time a)
+ -> Bool
+ -> IO (DTime, Maybe (Map Time a))
+sensing synthRef inRef _ = do
+ input <- readMVar inref
+ synth <- readMVar synthRef
+ let dt = (fromIntegral $ rate synth)/(fromIntegral $ outBuffSize synth)
+ return (dt, Just input)
+
+
+actuation = undefined
+
+mainSF :: (Message a) => SF (Map Time a) (Map Time a)
+mainSF = identity
diff --git a/Reactogon/Reactogon.hs b/Reactogon/Reactogon.hs
index 2656ba6..6f66009 100644
--- a/Reactogon/Reactogon.hs
+++ b/Reactogon/Reactogon.hs
@@ -1,33 +1,31 @@
module Main where
-import qualified MIDI as React
+import Auxiliary
+import MIDI
+import ClientState
+--import Reactimation
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
-import qualified Data.EventList.Relative.TimeMixed as EventListTM
-import qualified Control.Monad.Exception.Synchronous as Sync
-import qualified Control.Monad.Trans.Class as Trans
-
+import qualified Sound.MIDI.Message as MIDI
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 Control.Concurrent
+import Control.Monad
+import qualified Control.Monad.Exception.Synchronous as Sync
+import qualified Control.Monad.Trans.Class as Trans
+import qualified Data.EventList.Absolute.TimeBody as EventListAbs
+import qualified Data.EventList.Relative.TimeBody as EventList
+import qualified Data.EventList.Relative.TimeMixed as EventListTM
+import qualified Foreign.C.Error as E
+
+import qualified Data.Map as M
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)]
@@ -40,6 +38,7 @@ outLoop = concat [[(t,MIDI.Channel $ Channel.Cons
, Channel.messageBody =
Channel.Voice $ Voice.NoteOff (Voice.toPitch 60) (Voice.toVelocity 100)
})] | t <- [0,2..]]
+-}
reactogonName :: String
reactogonName = "Reactogon"
@@ -54,48 +53,64 @@ fsPortName :: String
fsPortName = "fluidsynth:midi"
main = do
- stateRef <- newMVar outLoop
+ inState <- newMVar M.empty
+ outState <- newMVar M.empty
Jack.handleExceptions $
Jack.withClientDefault reactogonName $ \client ->
- Jack.withPort client outPortName $ \output -> do
- Jack.withProcess client (process client stateRef output) $
+ Jack.withPort client outPortName $ \output ->
+ Jack.withPort client inPortName $ \input -> do
+ clientState <- Trans.lift $ newEmptyMVar
+ Jack.withProcess client
+ (jackLoop client clientState outState input output) $
Jack.withActivation client $ do
+ --frpid <- Trans.lift $ forkIO mainReact
Jack.connect client (reactogonName ++ ":" ++ outPortName) fsPortName
Trans.lift $ putStrLn $ "Started " ++ reactogonName
Trans.lift $ Jack.waitForBreak
-process ::
- Jack.Client ->
- MVar [(Time,MIDI.T)] ->
- JMIDI.Port Jack.Output ->
- Jack.NFrames ->
- Sync.ExceptionalT E.Errno IO ()
-process client stateRef output nframes@(Jack.NFrames nframesInt) =
- do
+jackLoop :: Jack.Client
+ -> MVar ClientState -- ^ MVar containing the client state (rate and buff size)
+ -> MVar EventQueue -- ^ MVar containing exiting events
+ -> JMIDI.Port Jack.Input -- ^ Jack input port
+ -> JMIDI.Port Jack.Output -- ^ Jack output port
+ -> Jack.NFrames -- ^ Buffer size for the ports
+ -> Sync.ExceptionalT E.Errno IO ()
+jackLoop client clientState outRef input output nframes@(Jack.NFrames nframesInt) = do
rate <- Trans.lift $ Jack.getSampleRate client
- events <- Trans.lift $ takeMVar stateRef
+ isEmptyState <- Trans.lift $ isEmptyMVar clientState
+ let updateClient c v = if isEmptyState then putMVar c v else void $ swapMVar c v
+ Trans.lift $ updateClient clientState $ ClientState { rate = rate
+ , buffSize = nframes
+ }
+ outEvents <- Trans.lift $ takeMVar outRef
lframe <- Trans.lift $ Jack.lastFrameTime client
+ inEventsT <- JMIDI.readEventsFromPort input nframes
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
+ inEvents :: EventQueue
+ inEvents = M.mapMaybe fromRawMessage $
+ M.fromList $ map (\(Jack.NFrames n,e) -> (currentTime + fromIntegral n/rateD, e)) $
+ EventListAbs.toPairList inEventsT
+ playableEvents = M.filterWithKey
+ (\t _ -> t - currentTime > - fromIntegral nframesInt / rateD) $
+ M.union inEvents outEvents
+ (processableEvents, futureEvents) = breakMap currentTime playableEvents
+ processableEvents' = M.toList processableEvents
Trans.lift $ print currentTime
- Trans.lift $ putMVar stateRef futureEvents
- if null processableEvents
+ Trans.lift $ putMVar outRef 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
+ else Trans.lift $ putStrLn "Event!"-}
+ let smartSub x y = if x < y then y - x else x - y
+ (firstTime,_) = head processableEvents'
+ Trans.lift $ print $
+ map ((* rateD) . smartSub firstTime . 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
+ map (\(t,e) -> (Jack.NFrames $ floor $ rateD * smartSub t currentTime
+ , toRawMessage e)) $
+ M.toList processableEvents
{-
else JMIDI.writeEventsToPort output nframes $
diff --git a/Reactogon/Shared.hs b/Reactogon/Shared.hs
new file mode 100644
index 0000000..b2f5309
--- /dev/null
+++ b/Reactogon/Shared.hs
@@ -0,0 +1,30 @@
+module Shared ( inRef
+ , outRef
+ , clientRef
+ ) where
+
+import ClientState
+import MIDI
+
+import Control.Concurrent.MVar
+import Data.Map ( Map
+ , empty
+ )
+import FRP.Yampa
+import Sound.JACK ( NFrames
+ )
+
+-- | MVar containing all the events given by the input port.
+inRef :: IO (MVar EventQueue)
+inRef = newMVar empty
+
+-- | MVar containing all the events to be given to the output port.
+outRef :: IO (MVar EventQueue)
+outRef = newMVar empty
+
+-- | MVar containing the state of the machine (JACK client and ports).
+clientRef :: Int -> NFrames -> NFrames -> IO (MVar ClientState)
+clientRef rate outSize inSize = newMVar $ ClientState { rate = rate
+ , outSize = outSize
+ , inSize = inSize
+ }
--
2.47.2