diff --git a/data/base/Chords.hs b/data/base/Chords.hs --- a/data/base/Chords.hs +++ b/data/base/Chords.hs @@ -2,28 +2,26 @@ import Midi + +chord :: + Integer -> [Integer] -> + [Midi.Event Midi.Message] ; +chord dur = + mergeMany . map (note dur) ; + + chord3 :: Integer -> Integer -> Integer -> Integer -> [Midi.Event Midi.Message] ; -chord3 dur p0 p1 p2 = - mergeMany [ - note dur p0, - note dur p1, - note dur p2 - ] ; +chord3 dur p0 p1 p2 = chord dur [p0, p1, p2] ; chord4 :: Integer -> Integer -> Integer -> Integer -> Integer -> [Midi.Event Midi.Message] ; -chord4 dur p0 p1 p2 p3 = - mergeMany [ - note dur p0, - note dur p1, - note dur p2, - note dur p3 - ] ; +chord4 dur p0 p1 p2 p3 = chord dur [p0, p1, p2, p3] ; + major, major7, minor, minor7 :: Integer -> Integer -> [Midi.Event Midi.Message] ; diff --git a/data/base/Midi.hs b/data/base/Midi.hs --- a/data/base/Midi.hs +++ b/data/base/Midi.hs @@ -14,6 +14,7 @@ controller, channel, transpose, transposeEvent, + changeTempo, changeTempoEvent, controlCurve, normalVelocity, emphasize, @@ -95,6 +96,14 @@ transposeEvent d (Event (On pitch velocity)) = Event (On (pitch+d) velocity) ; transposeEvent d (Event (Off pitch velocity)) = Event (Off (pitch+d) velocity) ; transposeEvent _d event = event ; + + +changeTempo :: Integer -> [Event Message] -> [Event Message] ; +changeTempo d = map ( changeTempoEvent d ) ; + +changeTempoEvent :: Integer -> Event a -> Event a ; +changeTempoEvent c (Wait d) = Wait (c*d) ; +changeTempoEvent _c event = event ; controlCurve :: Time -> Controller -> [Integer] -> [Event Message] ; diff --git a/live-sequencer.cabal b/live-sequencer.cabal --- a/live-sequencer.cabal +++ b/live-sequencer.cabal @@ -1,5 +1,5 @@ Name: live-sequencer -Version: 0.0.1 +Version: 0.0.2 Author: Henning Thielemann and Johannes Waldmann Maintainer: Johannes Waldmann , Henning Thielemann Category: Sound, Music, GUI @@ -13,6 +13,9 @@ An editor shows a textual description of music (like Haskore), an interpreter computes and emits a stream of MIDI events, and (that's the main point) the user can change the program on the fly. + Additionally the state of the interpreter is shown + in the form of the current reduced term + for educational and debugging purposes. . 1. example usage ***** . @@ -50,20 +53,32 @@ in order to assign the event to the particular MIDI channel. If you omit this constructor then the event is put to channel 0. . + In each step, the head of the @main@ stream gets reduced + to head normal form (with @:@ at the top), + and the first arg of the @:@ gets fully expanded + and it must be a MIDI event. + . 2. input language ***** . - The used language is Haskell with + The used language is syntactically almost a subset of Haskell with only strict pattern matching and pattern matching only at the definition level (no case), no local bindings (no lambda, let, where), - no types (no type inference, type signatures and type declarations are skipped) + no types (no type inference, type signatures and type declarations are skipped), + and with diet syntax (i.e. drastically reduced syntactic sugar, + like no layout rule, no do syntax, no list comprehension, no operator sections). . Semantics is similar to lazy evaluation, but we have no sharing. - In each step, the head of the @main@ stream gets reduced - to head normal form (with @:@ at the top), - and the first arg of the @:@ gets fully expanded - and it must be a midi event. + The design goal is that code can be changed + while the program is running. + This implies that evaluation of one expression + may give different results at different times + (e.g., during a live performance, + one changes some chords of a musical theme). + In turn, this implies that we do not store + and share results of evaluations, + hence, we don't have local bindings. . You may import and use the special functions 'Controls.checkBox', 'Controls.slider' @@ -285,13 +300,17 @@ Source-Repository this Type: git - Tag: 0.0 + Tag: 0.0.2 Location: http://code.haskell.org/~thielema/livesequencer/ Flag gui Description: Build the wxWidgets GUI for the sequencer Default: True +Flag mplayer + Description: Build the remote controller to the mplayer + Default: True + Flag httpServer Description: Enable access to modules via a web browser Default: True @@ -354,7 +373,7 @@ If impl(ghc>=7.0) GHC-Options: -fwarn-unused-do-bind -fwarn-missing-import-lists Build-Depends: - transformers >=0.2.2 && <0.3, + transformers >=0.2.2 && <0.4, explicit-exception >=0.1.5 && <0.2, parsec >=2.1 && <3.2, pretty >=1.0 && <1.2, @@ -377,8 +396,8 @@ Build-Depends: wx >=0.12.1 && <0.13, wxcore >=0.12.1 && <0.13, - stm >=2.2 && <2.3, - transformers >=0.2.2 && <0.3, + stm >=2.2 && <2.4, + transformers >=0.2.2 && <0.4, explicit-exception >=0.1.5 && <0.2, parsec >=2.1 && <3.2, pretty >=1.0 && <1.2, @@ -442,3 +461,27 @@ Other-Modules: HTTPServer.Option HTTPServer.GUI + +Executable live-mplayer-control + If flag(mplayer) + Build-Depends: + midi-alsa >=0.1.1 && <0.2, + midi >=0.1.5 && <0.2, + alsa-seq >=0.5 && <0.6, + alsa-core >=0.5 && <0.6, + unix >=2.4 && <2.6, + directory >=1.0 && <1.2, + transformers >=0.2.2 && <0.4, + base >=4.2 && <5 + Else + Buildable: False + + Hs-Source-Dirs: src + Main-is: MPlayer.hs + + Other-Modules: + Option.Utility + + GHC-Options: -threaded -Wall + If impl(ghc>=7.0) + GHC-Options: -fwarn-tabs -fwarn-incomplete-uni-patterns diff --git a/src/ALSA.hs b/src/ALSA.hs --- a/src/ALSA.hs +++ b/src/ALSA.hs @@ -22,6 +22,7 @@ import Control.Monad.Trans.Cont ( ContT(ContT), runContT, mapContT ) import Control.Monad ( (<=<) ) import Control.Functor.HT ( void ) +import qualified Data.Foldable as Fold import Data.Foldable ( Foldable, forM_, foldMap ) import Data.Monoid ( mappend ) @@ -102,11 +103,14 @@ Sequencer mode -> IO [Event.T] allNotesOff sq = do c <- Client.getId (handle sq) - return $ - map (Event.simple (Addr.Cons c (publicPort sq)) . - Event.CtrlEv Event.Controller . - flip MIDI.modeEvent ModeMsg.AllNotesOff) - [minBound .. maxBound] + return $ do + port <- Fold.toList $ ports sq + chan <- [minBound .. maxBound] + return $ + Event.simple (Addr.Cons c port) $ + Event.CtrlEv Event.Controller $ + MIDI.modeEvent chan ModeMsg.AllNotesOff + parseAndConnect :: (SndSeq.AllowInput mode, SndSeq.AllowOutput mode) => diff --git a/src/MPlayer.hs b/src/MPlayer.hs new file mode 100644 --- /dev/null +++ b/src/MPlayer.hs @@ -0,0 +1,133 @@ +{- | +This program receives MIDI commands +and controls MPlayer accordingly. + +The program listens to MIDI channel 0. + +When the program receives AllNotesOff or AllNotesOn it pauses MPlayer. + +If the program receives a MIDI-CC 0 with value 0, +then it seeks a certain position in the movie and triggers playback. + +You can set the seek time by sending the following controller changes: + +* CC 1: 100th seconds + +* CC 2: seconds + +* CC 3: minutes + +* CC 4: hours +-} +module Main where + +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel.Mode as ModeMsg +import qualified Sound.MIDI.ALSA.Check as Check + +import qualified Sound.ALSA.Sequencer.Client as Client +import qualified Sound.ALSA.Sequencer.Port as Port +import qualified Sound.ALSA.Sequencer.Event as Event +import qualified Sound.ALSA.Sequencer as SndSeq +import qualified Sound.ALSA.Exception as AlsaExc + +import qualified Control.Monad.Trans.State as MS +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad (when, forever, ) +import Data.Foldable (forM_, ) + +import qualified System.Directory as Dir +import qualified System.Posix.Files as File +import qualified System.IO as IO +import qualified System.Environment as Env +import qualified Control.Exception as Exc + +import qualified Text.Printf as Printf + +import Option.Utility (exitFailureMsg) + + +defltPipeName :: FilePath +defltPipeName = "/tmp/mppipe" + +seqName :: String +seqName = "MPlayer control" + +channel :: ChannelMsg.Channel +channel = ChannelMsg.toChannel 0 + +commands :: MonadIO io => IO.Handle -> [String] -> io () +commands pipe = + liftIO . mapM_ (\cmd -> putStrLn cmd >> IO.hPutStrLn pipe cmd) + + +data Time = Time {hours, minutes, seconds, fracSecs :: Int} + deriving (Show) + + +main :: IO () +main = do + args <- Env.getArgs + case args of + _:_:_ -> exitFailureMsg "too many arguments" + [pipeName] -> process pipeName + [] -> + Exc.bracket_ + (File.createNamedPipe defltPipeName 0o644 >> + putStrLn ("Created pipe: " ++ defltPipeName)) + (Dir.removeFile defltPipeName) + (process defltPipeName) + +process :: FilePath -> IO () +process pipeName = (do + pipe <- IO.openFile pipeName IO.WriteMode + IO.hSetBuffering pipe IO.LineBuffering + putStrLn $ "Start MPlayer like this:" + putStrLn $ "mplayer -input file=" ++ pipeName + putStrLn "" + + SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do + Client.setName (h :: SndSeq.T SndSeq.InputMode) seqName + putStrLn $ "Created sequencer: " ++ seqName + putStrLn $ "Start the live sequencer like this:" + putStrLn $ "live-sequencer --new-out-port control --connect-to " ++ show seqName + putStrLn "" + putStrLn $ "or connect with the live sequencer like this:" + putStrLn $ "aconnect Rewrite:1 " ++ show seqName + putStrLn "" + + Port.withSimple h "control" + (Port.caps [Port.capWrite, Port.capSubsWrite]) Port.typeMidiGeneric $ \ _p1 -> do + + flip MS.evalStateT (Time 0 0 0 0) $ forever $ do + ev <- liftIO $ Event.input h + -- print ev + forM_ (Check.mode channel ev) $ \mode -> + case mode of + {- + 'pause' toggles the playing mode + To make sure, that 'pause' stops, + we have to run the movie with 'seek' first. + -} + ModeMsg.AllNotesOff -> commands pipe ["seek 0", "pause"] + ModeMsg.AllSoundOff -> commands pipe ["seek 0", "pause"] + _ -> return () + + forM_ (Check.anyController channel ev) $ \(ctrl, val) -> do + let setTime update cc = + when (ctrl == VoiceMsg.toController cc) $ + MS.modify update + + setTime (\t -> t {fracSecs = val}) 1 + setTime (\t -> t {seconds = val}) 2 + setTime (\t -> t {minutes = val}) 3 + setTime (\t -> t {hours = val}) 4 + + when (ctrl == VoiceMsg.toController 0 && val == 0) $ do + (Time hr m s f) <- MS.get + commands pipe [Printf.printf "seek %d.%02d 2" (hr*3600 + m*60 + s) f] + + ) + `AlsaExc.catch` \e -> + putStrLn $ "alsa_exception: " ++ AlsaExc.show e