Commit d46b086c authored by Guerric Chupin's avatar Guerric Chupin

Deleted 'Unknown' directory.

parent 0c2a2ea9
{-# 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
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
{-# 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
{-# 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
module ClientState where
import Sound.JACK ( NFrames
)
import FRP.Yampa
data ClientState = ClientState { rate :: Int
, buffSize :: NFrames
, clientClock :: Time
}
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
-}
{-# 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
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
-}
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
}
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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment