tmp/Melody.hs

   1 module Main where
   2
   3 import qualified Sound.JACK.MIDI as JackMidi
   4 import qualified Sound.JACK as Jack
   5 import qualified Sound.MIDI.Message as MIDI
   6 import qualified Sound.MIDI.Message.Channel as Channel
   7 import qualified Sound.MIDI.Message.Channel.Voice as Voice
   8 import qualified Sound.MIDI.Message.Class.Construct as MidiCons
   9
  10 import qualified Control.Monad.Exception.Synchronous as Sync
  11 import qualified Control.Monad.Trans.Class as Trans
  12
  13 import qualified Data.EventList.Absolute.TimeBody as AbsEventList
  14 import qualified Data.EventList.Relative.TimeBody as EventList
  15 import qualified Data.EventList.Relative.TimeMixed as EventListTM
  16 import qualified Numeric.NonNegative.Wrapper as NonNegW
  17 import Data.IORef ( IORef
  18                   , newIORef
  19                   , readIORef
  20                   , writeIORef
  21                   )
  22
  23 import qualified Foreign.C.Error as E
  24
  25 import System.Environment (getProgName)
  26
  27 import Debug.Trace
  28
  29 scale :: [Channel.Pitch]
  30 scale = map Channel.toPitch [60, 62, 64, 65, 67, 69, 71, 72]
  31
  32 -- events :: EventList.T Jack.NFrames MIDI.T
  33 eventLoop :: EventList.T NonNegW.Double MIDI.T
  34 eventLoop =
  35     EventList.fromPairList $
  36     concatMap
  37         (\p ->
  38             let note on =
  39                     MidiCons.note (Channel.toChannel 0)
  40                         (Voice.normalVelocity, p, on)
  41             in  [(0, note True), (0.1, note False)])
  42         scale
  43
  44 {-
  45 eventList :: Jack.NFrames -> EventList.T Jack.NFrames MIDI.T
  46 eventList nframes = EventList.fromPairList $
  47   zip (map ((mappend nframes) . Jack.NFrames) [22050,44100..] ) $
  48   [MIDI.Channel $ Channel.Cons
  49     { Channel.messageChannel = Channel.toChannel 0
  50     , Channel.messageBody =
  51         Channel.Voice $ Voice.NoteOn (Voice.toPitch s) (Voice.toVelocity 100)
  52     } | s <- scale]
  53 -}
  54
  55 main :: IO ()
  56 main = do
  57     name <- getProgName
  58     stateRef <- newIORef (EventList.cycle eventLoop)
  59     Jack.handleExceptions $
  60         Jack.withClientDefault name $ \client ->
  61         Jack.withPort client "output" $ \output -> do
  62         Jack.withProcess client (process client stateRef output) $
  63             Jack.withActivation client $ do
  64                 Jack.connect client "Melody:output" "fluidsynth:midi"
  65                 Trans.lift $ putStrLn $ "started " ++ name ++ "..."
  66                 Trans.lift $ Jack.waitForBreak
  67
  68 process ::
  69     Jack.Client ->
  70     IORef (EventList.T NonNegW.Double MIDI.T) ->
  71     JackMidi.Port Jack.Output ->
  72     Jack.NFrames ->
  73     Sync.ExceptionalT E.Errno IO ()
  74 process client stateRef output nframes@(Jack.NFrames nframesInt) = do
  75     rate <- fmap fromIntegral $ Trans.lift $ Jack.getSampleRate client
  76     events <- Trans.lift $ readIORef stateRef
  77     let (currentEvents, futureEvents) =
  78             EventListTM.splitAtTime (fromIntegral nframesInt / rate) events
  79     Trans.lift $ writeIORef stateRef futureEvents
  80     JackMidi.writeEventsToPort output nframes $
  81         AbsEventList.mapTime (Jack.NFrames . NonNegW.toNumber) $
  82         EventList.toAbsoluteEventList 0 $
  83         EventList.resample rate $
  84         fst $ EventListTM.viewTimeR currentEvents