Reactogon/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   rate <- Trans.lift $ Jack.getSampleRate client
  82   lframe <- Trans.lift $ Jack.lastFrameTime client
  83   isEmptyState <- Trans.lift $ isEmptyMVar clientState
  84   let updateClient = if isEmptyState
  85                      then putMVar
  86                      else \c v -> void $ swapMVar c v
  87       rateD = fromIntegral rate
  88       (Jack.NFrames lframeInt) = lframe
  89       currentTime = fromIntegral lframeInt / rateD
  90   Trans.lift $ updateClient clientState $ ClientState { rate = rate
  91                                                       , buffSize = nframes
  92                                                       , clientClock = currentTime
  93                                                       }
  94   outEvents <- Trans.lift $ takeMVar outRef
  95   inEventsT <- JMIDI.readEventsFromPort input nframes
  96   let inEvents :: EventQueue
  97       inEvents = M.mapMaybe fromRawMessage $
  98         M.fromList $
  99         map (\(Jack.NFrames n,e) -> (currentTime + fromIntegral n/rateD, e)) $
 100         EventListAbs.toPairList inEventsT
 101   Trans.lift $ swapMVar inRef inEvents
 102   let playableEvents = M.filterWithKey
 103         (\t _ -> t - currentTime > - fromIntegral nframesInt / rateD) $
 104         M.union inEvents outEvents
 105       (processableEvents, futureEvents) = breakMap currentTime playableEvents
 106       processableEvents' = M.toList processableEvents
 107   Trans.lift $ print currentTime
 108   Trans.lift $ putMVar outRef futureEvents
 109   let smartSub x y = if x < y then y - x else x - y
 110       (firstTime,_) = head processableEvents'
 111   Trans.lift $ print $
 112     map ((* rateD) . smartSub firstTime . fst) processableEvents'
 113   JMIDI.writeEventsToPort output nframes $
 114     EventListAbs.fromPairList $
 115     map (\(t,e) -> (Jack.NFrames $ floor $ rateD * smartSub t currentTime
 116                    , toRawMessage e)) $
 117     M.toList processableEvents
 118
 119 {-
 120     else JMIDI.writeEventsToPort output nframes $
 121          EventListAbs.mapTime Jack.NFrames $
 122          EventList.toAbsoluteEventList 0 $
 123          EventList.mapTime (\(Jack.NFrames n) -> n) $
 124          EventList.fromPairList processableEvents
 125 -}