packages feed

reactive-jack (empty) → 0.2

raw patch · 6 files changed

+462/−0 lines, 6 filesdep +basedep +containersdep +data-accessorsetup-changed

Dependencies added: base, containers, data-accessor, event-list, explicit-exception, extensible-exceptions, jack, midi, non-negative, random, reactive-banana, reactive-midyim, transformers, utility-ht

Files

+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2013, Henning Thielemann++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * The names of contributors may not be used to endorse or promote+      products derived from this software without specific prior+      written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ reactive-jack.cabal view
@@ -0,0 +1,75 @@+Name:             reactive-jack+Version:          0.2+License:          BSD3+License-File:     LICENSE+Author:           Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>+Homepage:         http://www.haskell.org/haskellwiki/Reactive-balsa+Category:         Sound, Music+Build-Type:       Simple+Synopsis:         Process MIDI events via reactive-banana and JACK+Description:+   MIDI is the Musical Instrument Digital Interface,+   JACK is the JACK Audio Connection Kit.+   This package allows to manipulate a sequence of MIDI events via JACK.+   It is intended to be plugged as a playing assistant+   between a MIDI input device+   (e.g. a keyboard or a controller bank)+   and a MIDI controlled synthesizer+   (e.g. a software synthesizer or an external synthesizer).+   For software synthesizers see the Haskell packages+   @synthesizer-alsa@, @synthesizer-llvm@, @supercollider-midi@,+   @hsc3@, @YampaSynth@+   or the C packages @fluidsynth@ and @Timidity@.+   .+   Applications include:+   Remapping of channels, controller, instruments, keys,+   Keyboard splitting, Conversion from notes to controllers, Latch mode,+   Convert parallel chords to serial patterns,+   Automated change of MIDI controllers,+   Delay and echo.+   .+   It is intended that you write programs for MIDI stream manipulation.+   It is not intended to provide an executable program+   with all the functionality available+   in a custom programming interface.+   It is most fun to play with the stream editors in GHCi.+   However we provide an example module that demonstrates various effects.+Tested-With:      GHC==7.4.1+Cabal-Version:    >=1.6+Build-Type:       Simple+Source-Repository head+  type:     darcs+  location: http://hub.darcs.net/thielema/reactive-jack/++Source-Repository this+  type:     darcs+  location: http://hub.darcs.net/thielema/reactive-jack/+  tag:      0.2++Flag splitBase+  description: Choose the new smaller, split-up base package.++Library+  Build-Depends:+    reactive-midyim >=0.2 && <0.3,+    reactive-banana >=0.7 && <0.8,+    midi >=0.2 && <0.3,+    jack >=0.7 && <0.8,+    event-list >=0.1.1 && < 0.2,+    non-negative >=0.1 && <0.2,+    data-accessor >=0.2.1 && <0.3,+    utility-ht >=0.0.8 && <0.1,+    containers >=0.2 && <0.6,+    transformers >=0.2 && <0.6,+    explicit-exception >=0.1.7 && <0.2,+    extensible-exceptions >=0.1 && <0.2,+    random >=1 && <2,+    base >=4 && <5++  GHC-Options:      -Wall+  Hs-Source-Dirs:   src+  Exposed-Modules:+    Reactive.Banana.JACK.Process+    Reactive.Banana.JACK.Example+    Reactive.Banana.JACK.Common
+ src/Reactive/Banana/JACK/Common.hs view
@@ -0,0 +1,25 @@+module Reactive.Banana.JACK.Common where++import qualified Sound.JACK.MIDI as JackMidi+import qualified Sound.JACK.Exception as JackExc+import qualified Sound.JACK as Jack++import qualified Control.Monad.Exception.Synchronous as Sync++import Control.Monad.Trans.Reader (ReaderT, runReaderT, )+++data Handle =+   Handle {+      client :: Jack.Client,+      portIn :: JackMidi.Port Jack.Input,+      portOut :: JackMidi.Port Jack.Output+   }++with :: ReaderT Handle (Sync.ExceptionalT JackExc.All IO) () -> IO ()+with f =+    Jack.handleExceptions $+        Jack.withClientDefault "Haskell-MIDI-Filter" $ \c ->+        Jack.withPort c "input" $ \input ->+        Jack.withPort c "output" $ \output ->+        runReaderT f $ Handle c input output
+ src/Reactive/Banana/JACK/Example.hs view
@@ -0,0 +1,62 @@+module Reactive.Banana.JACK.Example where++import qualified Reactive.Banana.JACK.Process as Process++import qualified Reactive.Banana.MIDI.Controller as Ctrl+import qualified Reactive.Banana.MIDI.Common as Common+import qualified Reactive.Banana.MIDI.Process as ProcessMidi+import qualified Reactive.Banana.MIDI.Utility as RBU+import qualified Reactive.Banana.MIDI.Note as Note+import qualified Reactive.Banana.MIDI.Time as Time++import qualified Reactive.Banana.Combinators as RB+import qualified Reactive.Banana.Frameworks as RBF++import qualified Sound.MIDI.Message.Class.Check as Check+import qualified Sound.MIDI.Message as MidiMsg+import Sound.MIDI.Message.Channel.Voice (Velocity, normalVelocity, )++import qualified Control.Monad.Trans.State as MS+import Control.Monad (liftM2, liftM3, )+-- import Control.Applicative (pure, )+++melody ::+   RB.Event t (pitch, Velocity) ->+   RB.Event t [Note.Boundary pitch Velocity]+melody =+   fst .+   RBU.traverse []+      (\(pc, v) -> do+          off <- MS.get+          MS.put [Note.Boundary pc normalVelocity False]+          return $ off ++ [Note.Boundary pc v True])++time :: Rational -> Process.RelativeSeconds+time = Time.relative "example" . Time.Seconds++ticks ::+   (RBF.Frameworks t) =>+   Rational -> Process.Reactor t Process.RelativeTicks+ticks = Time.ticksFromSeconds . time++getTempo ::+   (Check.C ev, RBF.Frameworks t) =>+   RB.Event t ev ->+   Process.Reactor t+      (RB.Behavior t Process.RelativeTicks, RB.Event t ev)+getTempo ctrl =+   liftM3 (uncurry ProcessMidi.tempoCtrl Ctrl.tempoDefault)+      (ticks 0.15) (liftM2 (,) (ticks 0.5) (ticks 0.05)) (return ctrl)++loop ::+   (RBF.Frameworks t) =>+   RB.Behavior t Process.AbsoluteTicks ->+   RB.Event t MidiMsg.T -> Process.Reactor t (RB.Event t [MidiMsg.T])+loop times input = do+   -- beat <- ProcessMidi.beat . fst =<< getTempo input+   beat <- ProcessMidi.beatVar times . fst =<< getTempo input+   return $+      fmap (map Note.fromBnd) $ melody $+      fmap (const (Common.PitchChannel (Common.pitch 60) (Common.channel 0),+                   normalVelocity)) beat
+ src/Reactive/Banana/JACK/Process.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Rank2Types #-}+module Reactive.Banana.JACK.Process where++import qualified Reactive.Banana.JACK.Common as Common++import qualified Reactive.Banana.MIDI.Process as Process+import qualified Reactive.Banana.MIDI.Time as Time+import qualified Reactive.Banana.MIDI.IndexedMonad as IxMonad++import qualified Reactive.Banana.Combinators as RB+import qualified Reactive.Banana.Frameworks as RBF+import qualified Reactive.Banana.Switch as RBS+import Reactive.Banana.Combinators ((<@>), )++import qualified Sound.JACK.Exception as JackExc+import qualified Sound.JACK.MIDI as JackMidi+import qualified Sound.JACK as Jack++import qualified Sound.MIDI.Message as MidiMsg++import qualified Data.EventList.Absolute.TimeBody as EventListAbs+import qualified Data.Map as Map+import Data.Map (Map)++import Numeric.NonNegative.Class ((-|), )++import qualified Control.Monad.Exception.Synchronous as Sync+import qualified Foreign.C.Error as E++import qualified Data.Accessor.Basic as Acc++import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.State as MS+import qualified Control.Monad.Trans.Reader as MR+import Control.Monad.Trans.Reader (ReaderT, runReaderT, )+import Control.Monad.IO.Class (MonadIO, liftIO, )+import Control.Monad.Fix (MonadFix, )+import Control.Monad (when, )+import Control.Applicative (Applicative, pure, (<*>), )+import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef, )+import Data.Foldable (forM_, )+import Data.Monoid (Monoid, mappend, mempty, )++import Prelude hiding (sequence, )++++-- * make JACK reactive++data Context =+   Context {+      contextCycleStartRef :: IORef AbsoluteTicks,+      contextInQueueRef :: IORef InQueue,+      contextClient :: Jack.Client+   }++newtype Schedule = Schedule Int+   deriving (Eq, Ord, Enum, Show)++newtype Reactor t a =+   Reactor {+      runReactor :: ReaderT Context (MS.StateT Schedule (RBS.Moment t)) a+   } deriving (Functor, Applicative, Monad, MonadIO, MonadFix)+++instance Process.Moment Reactor where+   liftMoment = Reactor . MT.lift . MT.lift++instance IxMonad.C Reactor where+   point = return+   bind = (>>=)++instance Time.Timed Reactor where+   ticksFromSeconds t = do+      client <- Reactor $ MR.asks contextClient+      rate <- liftIO $ Jack.getSampleRate client+      return .+         Time.cons . Time.Ticks .+         round . (fromIntegral rate *) .+         Time.unSeconds . Time.decons $ t+++data InEvent =+   InEvent (Map Schedule [Handler AbsoluteTicks]) [MidiMsg.T]++instance Monoid InEvent where+   mempty = InEvent Map.empty []+   mappend (InEvent xs0 ys0) (InEvent xs1 ys1) =+      InEvent (Map.unionWith (++) xs0 xs1) (ys0++ys1)++inEventBeat :: Acc.T InEvent (Map Schedule [Handler AbsoluteTicks])+inEventBeat =+   Acc.fromSetGet+      (\beats (InEvent _ evs) -> InEvent beats evs)+      (\(InEvent beats _) -> beats)+++type InQueue = Map Jack.NFrames InEvent+type OutQueue = Map Jack.NFrames [MidiMsg.T]++run ::+   (JackExc.ThrowsErrno e) =>+   (forall t.+      (RBF.Frameworks t) =>+      RB.Event t MidiMsg.T -> RB.Event t [MidiMsg.T]) ->+   ReaderT Common.Handle (Sync.ExceptionalT e IO) ()+run f =+   runM (\ _ts xs -> return $ f xs)++runM ::+   (JackExc.ThrowsErrno e) =>+   (forall t.+    (RBF.Frameworks t) =>+    RB.Behavior t AbsoluteTicks ->+    RB.Event t MidiMsg.T -> Reactor t (RB.Event t [MidiMsg.T])) ->+   ReaderT Common.Handle (Sync.ExceptionalT e IO) ()+runM f = do+   MR.ReaderT $ \h -> do+      cycleStartRef <- MT.lift $ newIORef mempty+      inQueueRef    <- MT.lift $ newIORef Map.empty+      outQueueRef   <- MT.lift $ newIORef Map.empty+      (addEventHandler, runEventHandler) <- MT.lift RBF.newAddHandler+      (addTimeHandler,  runTimeHandler)  <- MT.lift RBF.newAddHandler+      MT.lift $ RBF.actuate =<< RBF.compile (do+         time <- RBF.fromChanges (error "uninitialized time") addTimeHandler+         evs <-+            flip MS.evalStateT (Schedule 0) .+            flip runReaderT+               (Context cycleStartRef inQueueRef (Common.client h)) .+            runReactor .+            f (fmap (absTicksFromNFrames . fst) time)+               =<< RBF.fromAddHandler addEventHandler+         RBF.reactimate $+            pure+               (\t -> modifyIORef outQueueRef . Map.insertWith (++) t)+               <*> fmap snd time <@> evs)+      Jack.withProcess (Common.client h)+            (process h cycleStartRef inQueueRef outQueueRef+               runTimeHandler runEventHandler) $+         Jack.withActivation (Common.client h) $+            MT.lift $ Jack.waitForBreak++++type Handler a = a -> IO ()+++viewQueueL ::+   InQueue ->+   Maybe+      ((Jack.NFrames, Either [Handler AbsoluteTicks] MidiMsg.T),+       InQueue)+viewQueueL q0 = do+   ((t, InEvent beats evs), q1) <- Map.minViewWithKey q0+   case (Map.minView beats, evs) of+      (Just (b,bs), _) ->+         Just ((t, Left b), Map.insert t (InEvent bs evs) q1)+      (Nothing, e:es) ->+         Just ((t, Right e),+               if null es then q1 else Map.insert t (InEvent Map.empty es) q1)+      (Nothing, []) -> viewQueueL q1++normalizeInQueue :: InQueue -> InQueue+normalizeInQueue =+   Map.filter (\(InEvent beats evs) -> not $ Map.null beats && null evs)++reduceQueueTime ::+   Jack.NFrames -> Map Jack.NFrames a -> Map Jack.NFrames a+reduceQueueTime dt = Map.mapKeysMonotonic (-| dt)+++process ::+   Common.Handle ->+   IORef AbsoluteTicks ->+   IORef InQueue ->+   IORef OutQueue ->+   Handler (Jack.NFrames, Jack.NFrames) ->+   Handler MidiMsg.T ->+   Jack.NFrames ->+   Sync.ExceptionalT E.Errno IO ()++process h cycleStartRef inQueueRef outQueueRef+      runTimeHandler runEventHandler size = do++   evs <- JackMidi.readEventsFromPort (Common.portIn h) size+   MT.lift $ modifyIORef inQueueRef $+      Map.unionWith mappend $ fmap (InEvent Map.empty) $+      Map.fromListWith (++) $ EventListAbs.toPairList $+      fmap (:[]) evs++   cycleStart <- MT.lift $ Jack.lastFrameTime $ Common.client h+   let cycleStartTicks = absTicksFromNFrames cycleStart+   MT.lift $ writeIORef cycleStartRef cycleStartTicks+   -- MT.lift $ print cycleStart+   let duration = size+       loop = do+          inQueueStart <- readIORef inQueueRef+          forM_ (viewQueueL inQueueStart) $ \((t,ev), remQueue) ->+             when (t<duration) $ do+                writeIORef inQueueRef remQueue+                -- the handlers may modify the inQueue in inQueueRef+                runTimeHandler (mappend cycleStart t, t)+                -- the handlers may modify the outQueue in outQueueRef+                either+                   (mapM_ ($ Time.inc (ticksFromNFrames t) cycleStartTicks))+                   runEventHandler ev+                loop++   MT.lift loop++   MT.lift $ modifyIORef inQueueRef $ reduceQueueTime duration++   outQueue <- MT.lift $ readIORef outQueueRef+   case Map.splitLookup duration outQueue of+      (now, pivot, later) -> do+         JackMidi.writeEventsToPort (Common.portOut h) size $+            EventListAbs.flatten $ EventListAbs.fromPairList $ Map.toList now+         MT.lift $ writeIORef outQueueRef $+            maybe id (Map.insert mempty) pivot $+            reduceQueueTime duration later++++type RelativeTicks = Time.T Reactor Time.Relative Time.Ticks+type AbsoluteTicks = Time.T Reactor Time.Absolute Time.Ticks+type RelativeSeconds = Time.T Reactor Time.Relative Time.Seconds++nframesFromTicks :: RelativeTicks -> Jack.NFrames+nframesFromTicks =+   Jack.NFrames . fromIntegral . Time.unTicks . Time.decons++ticksFromNFrames :: Jack.NFrames -> RelativeTicks+ticksFromNFrames (Jack.NFrames n) =+   Time.cons . Time.Ticks . fromIntegral $ n++absTicksFromNFrames :: Jack.NFrames -> AbsoluteTicks+absTicksFromNFrames (Jack.NFrames n) =+   Time.cons . Time.Ticks . fromIntegral $ n+++sendBeat ::+   Context -> Schedule ->+   Handler AbsoluteTicks -> AbsoluteTicks -> IO ()+sendBeat context sched runBeatHandler time = do+   cycleStart <- readIORef (contextCycleStartRef context)+   modifyIORef (contextInQueueRef context) $+      Map.insertWith mappend+         (nframesFromTicks $ Time.subSat time cycleStart)+         (InEvent (Map.singleton sched [runBeatHandler]) [])++cancelBeats :: Context -> Schedule -> IO ()+cancelBeats context sched = do+   modifyIORef (contextInQueueRef context) $+      normalizeInQueue .+      fmap (Acc.modify inEventBeat (Map.delete sched))+++instance Process.Reactor Reactor where+   reserveSchedule = Reactor $ MR.ReaderT $ \context -> do+      sched <- MS.get+      MS.modify succ+      (eEcho, runBeatHandler) <- MT.lift RBF.newEvent+      return+         (mapM_ (sendBeat context sched runBeatHandler),+          cancelBeats context sched, eEcho)