+++ /dev/null
-{-# LANGUAGE Arrows #-}
-
-module Arpeggiated where
-
-import FRP.Yampa
-
-import MIDI
-import Note
-
-arpeggiated :: SF (ControllerValue, Event Note) (Event Note)
-arpeggiated = proc (c,n) -> do
- non <- uncurry gate ^<< identity &&& arr (event False isOn) -< n
- non' <- fmap majorThird ^<< delayEvent t -< non
- non'' <- fmap perfectFifth ^<< delayEvent t -< non'
- (nof',
- nof'') <- makeOff *** makeOff -< (non',non'')
- -- It's assumed that the NoteOff event corresponding to n will be
- -- emitted.
- returnA -< mergeEvents [n, non, non', nof', non'', nof'']
- where onoffGap = 0.9*t
- t = 100000
- makeOff = delayEvent onoffGap <<^ fmap switchOnOff
+++ /dev/null
-module Auxiliary ( breakMap
- )where
-
-import Control.Arrow
-import Data.Map (Map)
-import qualified Data.Map as M
-
-dupl :: (Arrow a) => a b c -> a (b,b) (c,c)
-dupl f = f *** f
-
-breakMap :: (Ord k) => k -> Map k a -> (Map k a, Map k a)
-breakMap k m = (smaller, larger')
- where (smaller, maybeValue, larger) = M.splitLookup k m
- larger' = maybe larger (\v -> M.insert k v larger) maybeValue
+++ /dev/null
-{-# LANGUAGE Arrows #-}
-
-module AvgInt ( avgInt
- ) where
-
-import FRP.Yampa
-
-intNum :: Int
-intNum = 3
-
-maxTime :: DTime
-maxTime = 10
-
-infinity :: (Fractional a) => a
-infinity = 1/0
-
--- Outputs the average time between intNum of the last events. Goes to
--- infinity if less than intNum events have occured or if no event has
--- occured in maxTime.
-avgInt :: SF (Event a) DTime
-avgInt = avgInt' [] `switch` ((>>^ fst) . avgInt')
- where avgInt' :: [DTime] -> SF (Event a) (DTime, Event [DTime])
- avgInt' l = proc e -> do
- t <- localTime -< ()
- tooLate <- after maxTime [] -< ()
- let timeList = (e `tag` (appDTime intNum t l)) `lMerge` tooLate
- returnA -< (avgS intNum l, timeList)
-
-appDTime :: Int -> Time -> [DTime] -> [DTime]
-appDTime _ _ [] = [0]
-appDTime n t l = (t - head l):(take (n-1) l)
-
-avgS :: (Fractional a) => Int -> [a] -> a
-avgS n l
- | length l /= n = infinity
- | otherwise = foldl (+) 0 l / fromIntegral n
+++ /dev/null
-{-# LANGUAGE Arrows #-}
-
-module AvgIvl ( avgIvl
- ) where
-
-import FRP.Yampa
-
-import Debug.Trace
-
-ivlNum :: Int
-ivlNum = 3
-
-maxTime :: DTime
-maxTime = 5
-
-infinity :: (Fractional a) => a
-infinity = 1/0
-
--- Outputs the average time between ivlNum of the last events. Goes to
--- infinity if less than ivlNum events have occured or if no event has
--- occured in maxTime.
-avgIvl :: SF (Event a) DTime
-avgIvl = switch (constant infinity &&& constant (Event [])) avgIvl'
- where
- avgIvl' l = switch avgIvl'' (avgIvl')
- where avgIvl'' :: SF (Event a) (DTime, Event [DTime])
- avgIvl'' = proc e -> do
- e' <- notYet -< e
- t <- localTime -< ()
- tooLate <- after maxTime [] -< ()
- let timeList = (e' `tag` (appDTime ivlNum t l)) `lMerge` tooLate
- returnA -< (avgS ivlNum l, timeList)
-
-appDTime :: Int -> Time -> [DTime] -> [DTime]
-appDTime _ _ [] = [0]
-appDTime n t l = t:(take (n-1) l)
-
-avgS :: (Fractional a) => Int -> [a] -> a
-avgS n l
- | length l /= n = infinity
- | otherwise = foldl (+) 0 l / fromIntegral n
+++ /dev/null
-module ClientState where
-
-import Sound.JACK ( NFrames
- )
-import FRP.Yampa
-
-data ClientState = ClientState { rate :: Int
- , buffSize :: NFrames
- , clientClock :: Time
- }
+++ /dev/null
-module MIDI ( EventQueue
- , SampleRate
- , Pitch
- , toPitch
- , fromPitch
- , fromVelocity
- , toVelocity
- , Velocity
- , Message ( NoteOn
- , NoteOff
- , Control
- )
- , fromRawMessage
- , toRawMessage
- , ControllerIdx
- , ControllerValue
- ) where
-
-import qualified Sound.MIDI.Message as Message
-
-import Sound.MIDI.Message.Channel.Voice ( fromPitch
- , toPitch
- , fromVelocity
- , toVelocity
- )
-import qualified Sound.MIDI.Message.Channel as Channel
-import qualified Sound.MIDI.Message.Channel.Voice as Voice
-import Data.Map (Map)
-import FRP.Yampa
-
-type EventQueue = Map Time Message
-
-type SampleRate = Int
-
-type RawMessage = Message.T
-
-{-
-class Message a where
- fromMessage :: RawMessage -> Maybe a
- toMessage :: a -> RawMessage
--}
-
-type MidiVoice = Voice.T
-
-type Channel = Channel.Channel
-type Pitch = Voice.Pitch
-type Velocity = Voice.Velocity
-
-type ControllerIdx = Voice.Controller
-type ControllerValue = Int
-
-data Message = NoteOn Channel Pitch Velocity
- | NoteOff Channel Pitch Velocity
- | Control Channel ControllerIdx ControllerValue
- deriving(Show)
-
-fromRawMessage :: RawMessage -> Maybe Message
-fromRawMessage (Message.Channel (Channel.Cons c
- (Channel.Voice (Voice.NoteOn p v)))) = Just $ NoteOn c p v
-fromRawMessage (Message.Channel (Channel.Cons c
- (Channel.Voice (Voice.NoteOff p v)))) = Just $ NoteOff c p v
-fromRawMessage (Message.Channel (Channel.Cons c
- (Channel.Voice (Voice.Control n v)))) = Just $ Control c n v
-fromRawMessage _ = Nothing
-
-toRawMessage :: Message -> RawMessage
-toRawMessage (NoteOn c p v) = (Message.Channel $ Channel.Cons c
- (Channel.Voice $ Voice.NoteOn p v))
-toRawMessage (NoteOff c p v) = (Message.Channel $ Channel.Cons c
- (Channel.Voice $ Voice.NoteOff p v))
-toRawMessage (Control c n v) = (Message.Channel (Channel.Cons c
- (Channel.Voice (Voice.Control n v))))
-
-{-
-instance Message Note where
- fromMessage (Message.Channel (Channel.Cons c
- (Channel.Voice (Voice.NoteOn p v)))) = Just $ NoteOn c p v
- fromMessage (Message.Channel (Channel.Cons c
- (Channel.Voice (Voice.NoteOff p v)))) = Just $ NoteOff c p v
- fromMessage _ = Nothing
- toMessage (NoteOn c p v) = (Message.Channel $ Channel.Cons c
- (Channel.Voice $ Voice.NoteOn p v))
- toMessage (NoteOff c p v) = (Message.Channel $ Channel.Cons c
- (Channel.Voice $ Voice.NoteOff p v))
-{-
-instance Voice Note where
- fromVoice (Voice.NoteOn p v) = Just $ NoteOn p v
- fromVoice (Voice.NoteOff p v) = Just $ NoteOff p v
- fromVoice _ = Nothing
- toVoice (NoteOn p v) = Voice.NoteOn p v
- toVoice (NoteOff p v) = Voice.NoteOff p v
--}
--}
-{-
-
-data Control = Control ControllerIdx ControllerValue
--}
-{-
-instance Voice Control where
- fromVoice (Voice.Control i v) = Just $ Control i v
- fromVoice _ = Nothing
- toVoice (Control i v) = Voice.Control i v
--}
+++ /dev/null
-{-# LANGUAGE Arrows #-}
-
-module Reactimation where
-
-import Data.Map ( Map
- , empty
- )
-import qualified Data.Map as M
-import FRP.Yampa
-import Control.Concurrent.MVar
-import Sound.JACK ( NFrames(NFrames)
- )
-
-import MIDI
-import ClientState
---import Arpeggiated
-
-mainReact :: MVar EventQueue
- -> MVar EventQueue
- -> MVar ClientState
- -> IO ()
-mainReact inRef outRef clientRef =
- reactimate (initialize inRef) (sensing clientRef inRef) (actuation outRef) $
- proc _ -> do
- returnA -< M.empty
-
- {-mainSF-}
-
-initialize :: MVar EventQueue -> IO EventQueue
-initialize inRef = takeMVar inRef
-
-sensing :: MVar ClientState
- -> MVar EventQueue
- -> Bool
- -> IO (DTime, Maybe EventQueue)
-sensing clientRef inRef _ = do
- print "Reading."
- client <- readMVar clientRef
- input <- takeMVar inRef
- let (NFrames buff) = buffSize client
- dt = (fromIntegral $ rate client)/(fromIntegral buff)
- print "Done reading."
- return (dt, Just input)
-
-actuation :: MVar EventQueue
- -> Bool
- -> EventQueue
- -> IO Bool
-actuation outRef _ output = do
- print "Actuating."
- out <- takeMVar outRef
- putMVar outRef $ M.union output out
- print "Done actuating."
- return True
-
-mainSF :: SF EventQueue EventQueue
-mainSF = identity
+++ /dev/null
-module Main where
-
-import Auxiliary
-import MIDI
-import ClientState
-import Reactimation
-
-import qualified Sound.JACK as Jack
-import qualified Sound.JACK.MIDI as JMIDI
-import qualified Sound.MIDI.Message as MIDI
-import qualified Sound.MIDI.Message.Channel as Channel
-import qualified Sound.MIDI.Message.Channel.Voice as Voice
-import qualified Sound.MIDI.Message.Class.Construct as MidiCons
-
-import Control.Concurrent
-import Control.Monad
-import qualified Control.Monad.Exception.Synchronous as Sync
-import qualified Control.Monad.Trans.Class as Trans
-import qualified Data.EventList.Absolute.TimeBody as EventListAbs
-import qualified Data.EventList.Relative.TimeBody as EventList
-import qualified Data.EventList.Relative.TimeMixed as EventListTM
-import qualified Foreign.C.Error as E
-
-import qualified Data.Map as M
-import FRP.Yampa
-
-import Debug.Trace
-{-
--- | List of absolute times (at which events should occur) and events.
--- We assume that the list is sorted.
-outLoop :: [(Time,MIDI.T)]
-outLoop = concat [[(t,MIDI.Channel $ Channel.Cons
- { Channel.messageChannel = Channel.toChannel 4
- , Channel.messageBody =
- Channel.Voice $ Voice.NoteOn (Voice.toPitch 60) (Voice.toVelocity 100)
- }),(t+0.5,MIDI.Channel $ Channel.Cons
- { Channel.messageChannel = Channel.toChannel 4
- , Channel.messageBody =
- Channel.Voice $ Voice.NoteOff (Voice.toPitch 60) (Voice.toVelocity 100)
- })] | t <- [0,2..]]
--}
-
-rmcaName :: String
-rmcaName = "RMCA"
-
-inPortName :: String
-inPortName = "input"
-
-outPortName :: String
-outPortName = "output"
-
-fsPortName :: String
-fsPortName = "fluidsynth:midi"
-
-main = do
- inState <- newMVar M.empty
- outState <- newMVar M.empty
- Jack.handleExceptions $
- Jack.withClientDefault rmcaName $ \client ->
- Jack.withPort client outPortName $ \output ->
- Jack.withPort client inPortName $ \input -> do
- clientState <- Trans.lift $ newEmptyMVar
- Jack.withProcess client
- (jackLoop client clientState inState outState input output) $
- Jack.withActivation client $ do
- frpid <- Trans.lift $ forkIO $ mainReact inState outState clientState
- Jack.connect client (rmcaName ++ ":" ++ outPortName) fsPortName
- Trans.lift $ putStrLn $ "Started " ++ rmcaName
- Trans.lift $ Jack.waitForBreak
-
-jackLoop :: Jack.Client
- -> MVar ClientState -- ^ MVar containing the client state (rate and buff size)
- -> MVar EventQueue -- ^ MVar containing incoming events
- -> MVar EventQueue -- ^ MVar containing exiting events
- -> JMIDI.Port Jack.Input -- ^ Jack input port
- -> JMIDI.Port Jack.Output -- ^ Jack output port
- -> Jack.NFrames -- ^ Buffer size for the ports
- -> Sync.ExceptionalT E.Errno IO ()
-jackLoop client clientState inRef outRef
- input output nframes@(Jack.NFrames nframesInt) = do
- Trans.lift $ print "Entering Jack."
- rate <- Trans.lift $ Jack.getSampleRate client
- lframe <- Trans.lift $ Jack.lastFrameTime client
- isEmptyState <- Trans.lift $ isEmptyMVar clientState
- let updateClient = if isEmptyState
- then putMVar
- else \c v -> void $ swapMVar c v
- rateD = fromIntegral rate
- (Jack.NFrames lframeInt) = lframe
- currentTime = fromIntegral lframeInt / rateD
- Trans.lift $ updateClient clientState $ ClientState { rate = rate
- , buffSize = nframes
- , clientClock = currentTime
- }
- outEvents <- Trans.lift $ takeMVar outRef
- inEventsT <- JMIDI.readEventsFromPort input nframes
- let inEvents :: EventQueue
- inEvents = M.mapMaybe fromRawMessage $
- M.fromList $
- map (\(Jack.NFrames n,e) -> (currentTime + fromIntegral n/rateD, e)) $
- EventListAbs.toPairList inEventsT
- Trans.lift $ print "In the middle."
- Trans.lift $ putMVar inRef inEvents
- Trans.lift $ print "In the middle."
- let playableEvents = M.filterWithKey
- (\t _ -> t - currentTime > - fromIntegral nframesInt / rateD) $
- M.union inEvents outEvents
- (processableEvents, futureEvents) = breakMap currentTime playableEvents
- processableEvents' = M.toList processableEvents
- Trans.lift $ print currentTime
- Trans.lift $ putMVar outRef futureEvents
- let smartSub x y = if x < y then y - x else x - y
- (firstTime,_) = head processableEvents'
- Trans.lift $ print $
- map ((* rateD) . smartSub firstTime . fst) processableEvents'
- JMIDI.writeEventsToPort output nframes $
- EventListAbs.fromPairList $
- map (\(t,e) -> (Jack.NFrames $ floor $ rateD * smartSub t currentTime
- , toRawMessage e)) $
- M.toList processableEvents
- Trans.lift $ print "Exiting Jack."
-{-
- else JMIDI.writeEventsToPort output nframes $
- EventListAbs.mapTime Jack.NFrames $
- EventList.toAbsoluteEventList 0 $
- EventList.mapTime (\(Jack.NFrames n) -> n) $
- EventList.fromPairList processableEvents
--}
+++ /dev/null
-module Shared ( inRef
- , outRef
- , clientRef
- ) where
-
-import ClientState
-import MIDI
-
-import Control.Concurrent.MVar
-import Data.Map ( Map
- , empty
- )
-import FRP.Yampa
-import Sound.JACK ( NFrames
- )
-
--- | MVar containing all the events given by the input port.
-inRef :: IO (MVar EventQueue)
-inRef = newMVar empty
-
--- | MVar containing all the events to be given to the output port.
-outRef :: IO (MVar EventQueue)
-outRef = newMVar empty
-
--- | MVar containing the state of the machine (JACK client and ports).
-clientRef :: Int -> NFrames -> NFrames -> IO (MVar ClientState)
-clientRef rate outSize inSize = newMVar $ ClientState { rate = rate
- , outSize = outSize
- , inSize = inSize
- }
+++ /dev/null
-module Time ( toFrames
- , fromFrames
- ) where
-
-import FRP.Yampa
-import Sound.JACK (NFrames(NFrames))
-
-import MIDI
-
-toFrames :: SampleRate -> DTime -> NFrames
-toFrames s = NFrames . floor . (fromIntegral s *)
-
-fromFrames :: SampleRate -> NFrames -> DTime
-fromFrames s (NFrames n) = fromIntegral n/fromIntegral s
sourcephile / git / tmp / julm / arpeggigon.git / commitdiff