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
  28 scale :: [Channel.Pitch]
  29 scale = map Channel.toPitch [60, 62, 64, 65, 67, 69, 71, 72]
  30
  31 -- events :: EventList.T Jack.NFrames MIDI.T
  32 eventLoop :: EventList.T NonNegW.Double MIDI.T
  33 eventLoop =
  34     EventList.fromPairList $
  35     concatMap
  36         (\p ->
  37             let note on =
  38                     MidiCons.note (Channel.toChannel 0)
  39                         (Voice.normalVelocity, p, on)
  40             in  [(0, note True), (0.1, note False)])
  41         scale
  42
  43 {-
  44 eventList :: Jack.NFrames -> EventList.T Jack.NFrames MIDI.T
  45 eventList nframes = EventList.fromPairList $
  46   zip (map ((mappend nframes) . Jack.NFrames) [22050,44100..] ) $
  47   [MIDI.Channel $ Channel.Cons
  48     { Channel.messageChannel = Channel.toChannel 0
  49     , Channel.messageBody =
  50         Channel.Voice $ Voice.NoteOn (Voice.toPitch s) (Voice.toVelocity 100)
  51     } | s <- scale]
  52 -}
  53
  54 main :: IO ()
  55 main = do
  56     name <- getProgName
  57     stateRef <- newIORef (EventList.cycle eventLoop)
  58     Jack.handleExceptions $
  59         Jack.withClientDefault name $ \client ->
  60         Jack.withPort client "output" $ \output -> do
  61         Jack.withProcess client (process client stateRef output) $
  62             Jack.withActivation client $ do
  63                 --Jack.connect client "basic:output" "Midimon:input"
  64                 Trans.lift $ putStrLn $ "started " ++ name ++ "..."
  65                 Trans.lift $ Jack.waitForBreak
  66
  67 process ::
  68     Jack.Client ->
  69     IORef (EventList.T NonNegW.Double MIDI.T) ->
  70     JackMidi.Port Jack.Output ->
  71     Jack.NFrames ->
  72     Sync.ExceptionalT E.Errno IO ()
  73 process client stateRef output nframes@(Jack.NFrames nframesInt) = do
  74     rate <- fmap fromIntegral $ Trans.lift $ Jack.getSampleRate client
  75     events <- Trans.lift $ readIORef stateRef
  76     let (currentEvents, futureEvents) =
  77             EventListTM.splitAtTime (fromIntegral nframesInt / rate) events
  78     Trans.lift $ writeIORef stateRef futureEvents
  79     JackMidi.writeEventsToPort output nframes $
  80         AbsEventList.mapTime (Jack.NFrames . NonNegW.toNumber) $
  81         EventList.toAbsoluteEventList 0 $
  82         EventList.resample rate $
  83         fst $ EventListTM.viewTimeR currentEvents