Reactogon/Reactogon.hs

   1 module Main where
   2
   3 import qualified MIDI as React
   4
   5 import qualified Sound.JACK as Jack
   6 import qualified Sound.MIDI.Message as MIDI
   7 import qualified Sound.JACK.MIDI as JMIDI
   8 {-
   9 import Data.IORef ( IORef
  10                   , newIORef
  11                   , readIORef
  12                   , writeIORef
  13                   )
  14 -}
  15 import Control.Concurrent
  16 import qualified Foreign.C.Error as E
  17 import qualified Data.EventList.Relative.TimeBody as EventList
  18 import qualified Data.EventList.Absolute.TimeBody as EventListAbs
  19 import qualified Data.EventList.Relative.TimeMixed as EventListTM
  20 import qualified Control.Monad.Exception.Synchronous as Sync
  21 import qualified Control.Monad.Trans.Class as Trans
  22
  23 import qualified Sound.MIDI.Message.Channel as Channel
  24 import qualified Sound.MIDI.Message.Channel.Voice as Voice
  25 import qualified Sound.MIDI.Message.Class.Construct as MidiCons
  26
  27 import FRP.Yampa
  28
  29 import Debug.Trace
  30
  31 -- | List of absolute times (at which events should occur) and events.
  32 --   We assume that the list is sorted.
  33 outLoop :: [(Time,MIDI.T)]
  34 outLoop = concat [[(t,MIDI.Channel $ Channel.Cons
  35     { Channel.messageChannel = Channel.toChannel 4
  36     , Channel.messageBody =
  37         Channel.Voice $ Voice.NoteOn (Voice.toPitch 60) (Voice.toVelocity 100)
  38     }),(t+0.5,MIDI.Channel $ Channel.Cons
  39     { Channel.messageChannel = Channel.toChannel 4
  40     , Channel.messageBody =
  41         Channel.Voice $ Voice.NoteOff (Voice.toPitch 60) (Voice.toVelocity 100)
  42     })] | t <- [0,2..]]
  43
  44 reactogonName :: String
  45 reactogonName = "Reactogon"
  46
  47 inPortName :: String
  48 inPortName = "input"
  49
  50 outPortName :: String
  51 outPortName = "output"
  52
  53 fsPortName :: String
  54 fsPortName = "fluidsynth:midi"
  55
  56 main = do
  57   stateRef <- newMVar outLoop
  58   Jack.handleExceptions $
  59     Jack.withClientDefault reactogonName $ \client ->
  60     Jack.withPort client outPortName $ \output -> do
  61     Jack.withProcess client (process client stateRef output) $
  62       Jack.withActivation client $ do
  63       Jack.connect client (reactogonName ++ ":" ++ outPortName) fsPortName
  64       Trans.lift $ putStrLn $ "Started " ++ reactogonName
  65       Trans.lift $ Jack.waitForBreak
  66
  67 process ::
  68     Jack.Client ->
  69     MVar [(Time,MIDI.T)] ->
  70     JMIDI.Port Jack.Output ->
  71     Jack.NFrames ->
  72     Sync.ExceptionalT E.Errno IO ()
  73 process client stateRef output nframes@(Jack.NFrames nframesInt) =
  74   do
  75     rate <- Trans.lift $ Jack.getSampleRate client
  76     events <- Trans.lift $ takeMVar stateRef
  77     lframe <- Trans.lift $ Jack.lastFrameTime client
  78     let rateD = fromIntegral rate
  79         (Jack.NFrames lframeInt) = lframe
  80         currentTime = fromIntegral lframeInt / rateD
  81         playableEvents = filter
  82           (\(t,_) -> t - currentTime > - fromIntegral nframesInt / rateD) events
  83         (processableEvents, futureEvents) = break ((> currentTime) . fst) $
  84                                             playableEvents
  85     Trans.lift $ print currentTime
  86     Trans.lift $ putMVar stateRef futureEvents
  87     if null processableEvents
  88       then Trans.lift $ putStrLn "No events in queue."
  89       else Trans.lift $ putStrLn "Event!"
  90     let firstEventTime = fst $ head processableEvents
  91     Trans.lift $ print $ map ((* rateD) . smartSub currentTime . fst) processableEvents
  92     JMIDI.writeEventsToPort output nframes $
  93       EventListAbs.fromPairList $
  94       map (\(t,e) -> (Jack.NFrames $ floor $ rateD * smartSub t currentTime, e))
  95       processableEvents
  96
  97
  98 smartSub x y = if x < y then y - x else x - y
  99
 100 {-
 101     else JMIDI.writeEventsToPort output nframes $
 102          EventListAbs.mapTime Jack.NFrames $
 103          EventList.toAbsoluteEventList 0 $
 104          EventList.mapTime (\(Jack.NFrames n) -> n) $
 105          EventList.fromPairList processableEvents
 106 -}