myTestlll-1.0.0: Euterpea/IO/MUI/InstrumentBase.hs
{-# LANGUAGE Arrows #-}
module Euterpea.IO.MUI.InstrumentBase where
import qualified Codec.Midi as Midi
import FRP.UISF
import Data.Maybe
import Control.Monad
import Euterpea.IO.MUI.MidiWidgets (musicToMsgs)
import Euterpea.IO.MIDI
import Euterpea.Music.Note.Music hiding (transpose)
import Euterpea.Music.Note.Performance
type EMM = SEvent [MidiMessage]
-- The KeyData structure is maintained on a per-key basis in each instrument.
-- It is usually initialized by a call to getKeyData below
data KeyData = KeyData {
pressed :: Maybe Bool,
notation :: Maybe String,
offset :: Int
} deriving (Show, Eq)
-- KeyState carries the information about whether the key is being pressed or not,
-- and carries the information regarding the velocity generated by the last event
data KeyState = KeyState {
keypad:: Bool,
mouse :: Bool,
song :: Bool,
vel :: Midi.Velocity
} deriving (Show, Eq)
-- InstrumentData is a settings structure for the active instrument. It takes in
-- a bool that decides whether to show the pitch classes on the instrument, an
-- AbsPitch to decide by how much to transpose the instrument, a bool that indicates
-- whether a sustain pedal is being held down and a list describing the
data InstrumentData = InstrumentData {
showNotation::Bool,
keyPairs :: Maybe [(AbsPitch, Bool)],
transpose :: AbsPitch,
pedal :: Bool
} deriving (Show, Eq)
-- A simple predicate to determine whether a given key should be displayed as pressed
isKeyDown :: KeyState -> Bool
isKeyDown (KeyState False False False _) = False
isKeyDown _ = True
-- A simple predicate to determine whether a given key is being pressed by the user
isKeyPlay :: KeyState -> Bool
isKeyPlay (KeyState False False _ _) = False
isKeyPlay _ = True
-- A neutral InstrumentData structure.
defaultInstrumentData :: InstrumentData
defaultInstrumentData = InstrumentData False Nothing 0 False
-----------------------------
-- INSTRUMENT DATA WIDGETS --
-----------------------------
-- Notation Widget
addNotation :: UISF InstrumentData InstrumentData
addNotation = proc inst -> do
notA <- checkbox "Notation" False -< ()
returnA -< inst { showNotation = notA }
-- Transpose Widget
addTranspose :: UISF InstrumentData InstrumentData
addTranspose = proc inst -> do
tp <- withDisplay $ hiSlider 1 (-6,6) 0 -< ()
returnA -< inst { transpose = tp }
-- Pedal Widget
addPedal :: UISF InstrumentData InstrumentData
addPedal = proc inst -> do
ped <- checkbox "Pedal" False -< ()
returnA -< inst { pedal = ped }
-----------------------------
-- ECHO WIDGET --
-----------------------------
-- This is a widget that adds an echo to a MidiMessage signal
addEcho :: UISF EMM EMM
addEcho = title "Echo" $ leftRight $ proc m -> do
r <- title "Decay Rate" $ withDisplay (hSlider (0,0.9) 0.5) -< ()
f <- title "Echoing Frequency" $ withDisplay (hSlider (1,10) 10) -< ()
rec let m' = removeNull $ m ~++ s
s <- vdelay -< (1.0/f, fmap (mapMaybe (decay 0.1 r)) m')
returnA -< m'
removeNull :: Maybe [MidiMessage] -> Maybe [MidiMessage]
removeNull Nothing = Nothing
removeNull (Just []) = Nothing
removeNull mm = mm
decay :: Time -> Double -> MidiMessage -> Maybe MidiMessage
decay dur r m =
let f c k v d = if v > 0
then Just (ANote c k (truncate (fromIntegral v * r)) d)
else Nothing
in case m of
ANote c k v d -> f c k v d
Std (Midi.NoteOn c k v) -> f c k v dur
_ -> Nothing
-----------------------------
-- INSTRUMENT SELECT --
-----------------------------
-- Sets the midi instrument on a given channel. Takes the channel and a starting instrument as an argument
selectInstrument :: Midi.Channel -> Int -> UISF EMM EMM
selectInstrument chn i = title "Instrument" $ proc msg -> do
instrNum <- hiSlider 1 (0,127) i -< ()
display -< (toEnum :: Int -> InstrumentName) instrNum
instrNum' <- unique -< instrNum
returnA -< fmap (\x -> [Std $ Midi.ProgramChange chn x]) instrNum' ~++ msg
-----------------------------
-- SONG SELECTION --
-----------------------------
-- Takes an array of tuples of song names and Music values and creates a player for them
-- Emits a midi signal that can be routed through other filters before being passed
-- on to a midiOut sink.
songPlayer :: [(String, Music Pitch)] -> UISF () EMM
songPlayer songList = proc _ -> do
i <- pickSong songList -< ()
let song = fmap (\x -> snd $ songList !! x) i
let msgs = fmap (musicToMsgs False [] . toMusic1) song
(out, _) <- eventBuffer -< maybe NoBOp MergeInBuffer msgs
returnA -< out
pickSong :: [(String, Music Pitch)] -> UISF () (SEvent Int)
pickSong [] = title "No Songs Imported" $ proc _ -> returnA -< Nothing
pickSong songList = title "Available Songs" $ leftRight $ proc _ -> do
i <- topDown $ radio (fst $ unzip songList) 0 -< ()
playBtn <- edge <<< button "Play" -< ()
returnA -< fmap (const i) playBtn
-----------------------------
-- OTHER HELPERS --
-----------------------------
-- Converts a set of midi messages to a set of pitch and state pairs to be used
-- in an InstrumentData structure
mmToPair :: [MidiMessage] -> [(AbsPitch, Bool)]
mmToPair [] = []
mmToPair (Std (Midi.NoteOn _ k _) : rest) = (k, True) : mmToPair rest
mmToPair (Std (Midi.NoteOff _ k _) : rest)= (k, False) : mmToPair rest
mmToPair (ANote {} :_) = error "ANote not implemented"
mmToPair (_:rest) = mmToPair rest
-- Given a channel, converts a list of pitches, states and velocities to a string of
-- midi messages, the opposite of mmToPair
pairToMsg :: Midi.Channel -> [(AbsPitch, Bool, Midi.Velocity)] -> [MidiMessage]
pairToMsg ch = map f where
f (ap, b, vel) | b = Std (Midi.NoteOn ch ap vel)
| not b = Std (Midi.NoteOff ch ap 0)
-- Given an absolute pitch, looks though the InstrumentData to create the related
-- KeyData structure containing the pressed information, the string to use for
-- pitch notation and the adjusted pitch
getKeyData :: AbsPitch -> InstrumentData -> KeyData
getKeyData ap (InstrumentData isShow pairs trans _) =
KeyData (if isNothing pairs then Nothing
else Control.Monad.mplus (lookup ap (fromJust pairs)) Nothing)
(if isShow then Just (show $ fst $ pitch ap) else Nothing)
(ap + trans)
-- Looks through a string of midi messages and returns the first channel in a
-- command, if it finds one. Counter to setChannel
detectChannel :: [MidiMessage] -> Maybe Midi.Channel
detectChannel [] = Nothing
detectChannel (ANote c _ _ _:_) = Just c
detectChannel (Std (NoteOn c _ _):_) = Just c
detectChannel (Std (NoteOff c _ _):_) = Just c
detectChannel (Std (KeyPressure c _ _):_) = Just c
detectChannel (Std (ControlChange c _ _):_) = Just c
detectChannel (Std (ProgramChange c _):_) = Just c
detectChannel (Std (ChannelPressure c _):_) = Just c
detectChannel (Std (PitchWheel c _):_) = Just c
detectChannel (_:as) = detectChannel as
-- Sets all midi messages to a single channel. This will destroy any custom commands.
-- Used inside the guitar and piano, which coerce their streams to their own channel.
setChannel :: Int -> [MidiMessage] -> [MidiMessage]
setChannel c (ANote _ k v d:as) = ANote c k v d : setChannel c as
setChannel c (Std (NoteOn _ k v):as) = Std (NoteOn c k v) : setChannel c as
setChannel c (Std (NoteOff _ k v):as) = Std (NoteOff c k v) : setChannel c as
setChannel c (Std (KeyPressure _ k p):as) = Std (KeyPressure c k p) : setChannel c as
setChannel c (Std (ControlChange _ cn cv):as) = Std (ControlChange c cn cv) : setChannel c as
setChannel c (Std (ProgramChange _ p):as) = Std (ProgramChange c p) : setChannel c as
setChannel c (Std (ChannelPressure _ p):as) = Std (ChannelPressure c p) : setChannel c as
setChannel c (Std (PitchWheel _ p):as) = Std (PitchWheel c p) : setChannel c as
setChannel _ x = x