Reactogon/Translator/Reactogon.hs

   1 module Main where
   2
   3 import Auxiliary
   4 import MIDI
   5 import ClientState
   6 import Reactimation
   7
   8 import qualified Sound.JACK as Jack
   9 import qualified Sound.JACK.MIDI as JMIDI
  10 import qualified Sound.MIDI.Message as MIDI
  11 import qualified Sound.MIDI.Message.Channel as Channel
  12 import qualified Sound.MIDI.Message.Channel.Voice as Voice
  13 import qualified Sound.MIDI.Message.Class.Construct as MidiCons
  14
  15 import Control.Concurrent
  16 import Control.Monad
  17 import qualified Control.Monad.Exception.Synchronous as Sync
  18 import qualified Control.Monad.Trans.Class as Trans
  19 import qualified Data.EventList.Absolute.TimeBody as EventListAbs
  20 import qualified Data.EventList.Relative.TimeBody as EventList
  21 import qualified Data.EventList.Relative.TimeMixed as EventListTM
  22 import qualified Foreign.C.Error as E
  23
  24 import qualified Data.Map as M
  25 import FRP.Yampa
  26
  27 import Debug.Trace
  28 {-
  29 -- | List of absolute times (at which events should occur) and events.
  30 --   We assume that the list is sorted.
  31 outLoop :: [(Time,MIDI.T)]
  32 outLoop = concat [[(t,MIDI.Channel $ Channel.Cons
  33     { Channel.messageChannel = Channel.toChannel 4
  34     , Channel.messageBody =
  35         Channel.Voice $ Voice.NoteOn (Voice.toPitch 60) (Voice.toVelocity 100)
  36     }),(t+0.5,MIDI.Channel $ Channel.Cons
  37     { Channel.messageChannel = Channel.toChannel 4
  38     , Channel.messageBody =
  39         Channel.Voice $ Voice.NoteOff (Voice.toPitch 60) (Voice.toVelocity 100)
  40     })] | t <- [0,2..]]
  41 -}
  42
  43 reactogonName :: String
  44 reactogonName = "Reactogon"
  45
  46 inPortName :: String
  47 inPortName = "input"
  48
  49 outPortName :: String
  50 outPortName = "output"
  51
  52 fsPortName :: String
  53 fsPortName = "fluidsynth:midi"
  54
  55 main = do
  56   inState <- newMVar M.empty
  57   outState <- newMVar M.empty
  58   Jack.handleExceptions $
  59     Jack.withClientDefault reactogonName $ \client ->
  60     Jack.withPort client outPortName $ \output ->
  61     Jack.withPort client inPortName $ \input -> do
  62     clientState <- Trans.lift $ newEmptyMVar
  63     Jack.withProcess client
  64       (jackLoop client clientState inState outState input output) $
  65       Jack.withActivation client $ do
  66       frpid <- Trans.lift $ forkIO $ mainReact inState outState clientState
  67       Jack.connect client (reactogonName ++ ":" ++ outPortName) fsPortName
  68       Trans.lift $ putStrLn $ "Started " ++ reactogonName
  69       Trans.lift $ Jack.waitForBreak
  70
  71 jackLoop :: Jack.Client
  72          -> MVar ClientState -- ^ MVar containing the client state (rate and buff size)
  73          -> MVar EventQueue -- ^ MVar containing incoming events
  74          -> MVar EventQueue -- ^ MVar containing exiting events
  75          -> JMIDI.Port Jack.Input -- ^ Jack input port
  76          -> JMIDI.Port Jack.Output -- ^ Jack output port
  77          -> Jack.NFrames -- ^ Buffer size for the ports
  78          -> Sync.ExceptionalT E.Errno IO ()
  79 jackLoop client clientState inRef outRef
  80          input output nframes@(Jack.NFrames nframesInt) = do
  81   Trans.lift $ print "Entering Jack."
  82   rate <- Trans.lift $ Jack.getSampleRate client
  83   lframe <- Trans.lift $ Jack.lastFrameTime client
  84   isEmptyState <- Trans.lift $ isEmptyMVar clientState
  85   let updateClient = if isEmptyState
  86                      then putMVar
  87                      else \c v -> void $ swapMVar c v
  88       rateD = fromIntegral rate
  89       (Jack.NFrames lframeInt) = lframe
  90       currentTime = fromIntegral lframeInt / rateD
  91   Trans.lift $ updateClient clientState $ ClientState { rate = rate
  92                                                       , buffSize = nframes
  93                                                       , clientClock = currentTime
  94                                                       }
  95   outEvents <- Trans.lift $ takeMVar outRef
  96   inEventsT <- JMIDI.readEventsFromPort input nframes
  97   let inEvents :: EventQueue
  98       inEvents = M.mapMaybe fromRawMessage $
  99         M.fromList $
 100         map (\(Jack.NFrames n,e) -> (currentTime + fromIntegral n/rateD, e)) $
 101         EventListAbs.toPairList inEventsT
 102   Trans.lift $ print "In the middle."
 103   Trans.lift $ putMVar inRef inEvents
 104   Trans.lift $ print "In the middle."
 105   let playableEvents = M.filterWithKey
 106         (\t _ -> t - currentTime > - fromIntegral nframesInt / rateD) $
 107         M.union inEvents outEvents
 108       (processableEvents, futureEvents) = breakMap currentTime playableEvents
 109       processableEvents' = M.toList processableEvents
 110   Trans.lift $ print currentTime
 111   Trans.lift $ putMVar outRef futureEvents
 112   let smartSub x y = if x < y then y - x else x - y
 113       (firstTime,_) = head processableEvents'
 114   Trans.lift $ print $
 115     map ((* rateD) . smartSub firstTime . fst) processableEvents'
 116   JMIDI.writeEventsToPort output nframes $
 117     EventListAbs.fromPairList $
 118     map (\(t,e) -> (Jack.NFrames $ floor $ rateD * smartSub t currentTime
 119                    , toRawMessage e)) $
 120     M.toList processableEvents
 121   Trans.lift $ print "Exiting Jack."
 122 {-
 123     else JMIDI.writeEventsToPort output nframes $
 124          EventListAbs.mapTime Jack.NFrames $
 125          EventList.toAbsoluteEventList 0 $
 126          EventList.mapTime (\(Jack.NFrames n) -> n) $
 127          EventList.fromPairList processableEvents
 128 -}