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 outState input output) $
  65       Jack.withActivation client $ do
  66       --frpid <- Trans.lift $ forkIO mainReact
  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 exiting events
  74          -> JMIDI.Port Jack.Input -- ^ Jack input port
  75          -> JMIDI.Port Jack.Output -- ^ Jack output port
  76          -> Jack.NFrames -- ^ Buffer size for the ports
  77          -> Sync.ExceptionalT E.Errno IO ()
  78 jackLoop client clientState outRef input output nframes@(Jack.NFrames nframesInt) = do
  79     rate <- Trans.lift $ Jack.getSampleRate client
  80     isEmptyState <- Trans.lift $ isEmptyMVar clientState
  81     let updateClient c v = if isEmptyState then putMVar c v else void $ swapMVar c v
  82     Trans.lift $ updateClient clientState $ ClientState { rate = rate
  83                                              , buffSize = nframes
  84                                              }
  85     outEvents <- Trans.lift $ takeMVar outRef
  86     lframe <- Trans.lift $ Jack.lastFrameTime client
  87     inEventsT <- JMIDI.readEventsFromPort input nframes
  88     let rateD = fromIntegral rate
  89         (Jack.NFrames lframeInt) = lframe
  90         currentTime = fromIntegral lframeInt / rateD
  91         inEvents :: EventQueue
  92         inEvents = M.mapMaybe fromRawMessage $
  93           M.fromList $ map (\(Jack.NFrames n,e) -> (currentTime + fromIntegral n/rateD, e)) $
  94           EventListAbs.toPairList inEventsT
  95         playableEvents = M.filterWithKey
  96           (\t _ -> t - currentTime > - fromIntegral nframesInt / rateD) $
  97           M.union inEvents outEvents
  98         (processableEvents, futureEvents) = breakMap currentTime playableEvents
  99         processableEvents' = M.toList processableEvents
 100     Trans.lift $ print currentTime
 101     Trans.lift $ putMVar outRef futureEvents
 102     {-if null processableEvents
 103       then Trans.lift $ putStrLn "No events in queue."
 104       else Trans.lift $ putStrLn "Event!"-}
 105     let smartSub x y = if x < y then y - x else x - y
 106         (firstTime,_) = head processableEvents'
 107     Trans.lift $ print $
 108       map ((* rateD) . smartSub firstTime . fst) processableEvents'
 109     JMIDI.writeEventsToPort output nframes $
 110       EventListAbs.fromPairList $
 111       map (\(t,e) -> (Jack.NFrames $ floor $ rateD * smartSub t currentTime
 112                      , toRawMessage e)) $
 113       M.toList processableEvents
 114
 115 {-
 116     else JMIDI.writeEventsToPort output nframes $
 117          EventListAbs.mapTime Jack.NFrames $
 118          EventList.toAbsoluteEventList 0 $
 119          EventList.mapTime (\(Jack.NFrames n) -> n) $
 120          EventList.fromPairList processableEvents
 121 -}