module Music.Theory.Array.CSV.Midi.MND where
import Data.List.Split
import Data.List
import Data.Maybe
import Data.Word
import qualified Music.Theory.Array.CSV as T
import qualified Music.Theory.Math as T
import qualified Music.Theory.Read as T
import qualified Music.Theory.Time.Seq as T
data_value_pp :: Real t => Int -> t -> String
data_value_pp k r =
if T.whole_to_precision k r
then show (T.real_floor_int r)
else T.real_pp k r
type Channel = Word8
csv_mnd_hdr :: [String]
csv_mnd_hdr = ["time","on/off","note","velocity","channel","param"]
type Param = (String,Double)
param_parse :: String -> [Param]
param_parse str =
let f x = case splitOn "=" x of
[lhs,rhs] -> (lhs,read rhs)
_ -> error ("param_parse: " ++ x)
in if null str then [] else map f (splitOn ";" str)
param_pp :: Int -> [Param] -> String
param_pp k =
let f (lhs,rhs) = concat [lhs,"=",T.real_pp k rhs]
in intercalate ";" . map f
type MND t n = (t,String,n,n,Channel,[Param])
csv_mnd_parse :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> [MND t n]
csv_mnd_parse (hdr,dat) =
let err x = error ("csv_mnd_read: " ++ x)
f m = case m of
[st,msg,mnn,vel,ch,pm] ->
(T.reads_exact_err "time:real" st
,msg
,T.reads_exact_err "note:real" mnn
,T.reads_exact_err "velocity:real" vel
,T.reads_exact_err "channel:int" ch
,param_parse pm)
_ -> err "entry?"
in case hdr of
Just hdr' -> if hdr' == csv_mnd_hdr then map f dat else err "header?"
Nothing -> err "no header?"
load_csv :: FilePath -> IO (T.CSV_Table String)
load_csv = T.csv_table_read (True,',',False,T.CSV_No_Align) id
csv_mnd_read :: (Read t,Real t,Read n,Real n) => FilePath -> IO [MND t n]
csv_mnd_read = fmap csv_mnd_parse . load_csv
csv_mnd_write :: (Real t,Real n) => Int -> FilePath -> [MND t n] -> IO ()
csv_mnd_write r_prec nm =
let un_node (st,msg,mnn,vel,ch,pm) =
[T.real_pp r_prec st
,msg
,data_value_pp r_prec mnn
,data_value_pp r_prec vel
,show ch
,param_pp r_prec pm]
with_hdr dat = (Just csv_mnd_hdr,dat)
in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node
type Event n = (n,n,Channel,[Param])
midi_tseq_to_midi_wseq :: (Num t,Eq n) => T.Tseq t (T.Begin_End (Event n)) -> T.Wseq t (Event n)
midi_tseq_to_midi_wseq = T.tseq_begin_end_to_wseq (\(n0,_,c0,_) (n1,_,c1,_) -> c0 == c1 && n0 == n1)
midi_wseq_to_midi_tseq :: (Num t,Ord t) => T.Wseq t x -> T.Tseq t (T.Begin_End x)
midi_wseq_to_midi_tseq = T.wseq_begin_end
mnd_to_tseq :: Num n => [MND t n] -> T.Tseq t (T.Begin_End (Event n))
mnd_to_tseq =
let mk_node (st,msg,mnn,vel,ch,pm) =
case msg of
"on" -> Just (st,T.Begin (mnn,vel,ch,pm))
"off" -> Just (st,T.End (mnn,0,ch,pm))
_ -> Nothing
in mapMaybe mk_node
csv_mnd_read_tseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Tseq t (T.Begin_End (Event n)))
csv_mnd_read_tseq = fmap mnd_to_tseq . csv_mnd_read
csv_mnd_write_tseq :: (Real t,Real n) => Int -> FilePath -> T.Tseq t (T.Begin_End (Event n)) -> IO ()
csv_mnd_write_tseq r_prec nm sq =
let f (t,e) = case e of
T.Begin (n,v,c,p) -> (t,"on",n,v,c,p)
T.End (n,_,c,p) -> (t,"off",n,0,c,p)
in csv_mnd_write r_prec nm (map f sq)
csv_mndd_hdr :: [String]
csv_mndd_hdr = ["time","duration","message","note","velocity","channel","param"]
type MNDD t n = (t,t,String,n,n,Channel,[Param])
csv_mndd_parse :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> [MNDD t n]
csv_mndd_parse (hdr,dat) =
let err x = error ("csv_mndd_read: " ++ x)
f m =
case m of
[st,du,msg,mnn,vel,ch,pm] ->
(T.reads_exact_err "time" st
,T.reads_exact_err "duration" du
,msg
,T.reads_exact_err "note" mnn
,T.reads_exact_err "velocity" vel
,T.reads_exact_err "channel" ch
,param_parse pm)
_ -> err "entry?"
in case hdr of
Just hdr' -> if hdr' == csv_mndd_hdr then map f dat else err "header?"
Nothing -> err "no header?"
csv_mndd_read :: (Read t,Real t,Read n,Real n) => FilePath -> IO [MNDD t n]
csv_mndd_read = fmap csv_mndd_parse . load_csv
csv_mndd_write :: (Real t,Real n) => Int -> FilePath -> [MNDD t n] -> IO ()
csv_mndd_write r_prec nm =
let un_node (st,du,msg,mnn,vel,ch,pm) =
[T.real_pp r_prec st,T.real_pp r_prec du,msg
,data_value_pp r_prec mnn,data_value_pp r_prec vel
,show ch
,param_pp r_prec pm]
with_hdr dat = (Just csv_mndd_hdr,dat)
in T.csv_table_write id T.def_csv_opt nm . with_hdr . map un_node
mndd_to_wseq :: [MNDD t n] -> T.Wseq t (Event n)
mndd_to_wseq =
let mk_node (st,du,msg,mnn,vel,ch,pm) =
case msg of
"note" -> Just ((st,du),(mnn,vel,ch,pm))
_ -> Nothing
in mapMaybe mk_node
csv_mndd_read_wseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Wseq t (Event n))
csv_mndd_read_wseq = fmap mndd_to_wseq . csv_mndd_read
csv_mndd_write_wseq :: (Real t,Real n) => Int -> FilePath -> T.Wseq t (Event n) -> IO ()
csv_mndd_write_wseq r_prec nm =
let f ((st,du),(mnn,vel,ch,pm)) = (st,du,"note",mnn,vel,ch,pm)
in csv_mndd_write r_prec nm . map f
csv_midi_parse_wseq :: (Read t,Real t,Read n,Real n) => T.CSV_Table String -> T.Wseq t (Event n)
csv_midi_parse_wseq (hdr,dat) = do
case hdr of
Just hdr' -> if hdr' == csv_mnd_hdr
then midi_tseq_to_midi_wseq (mnd_to_tseq (csv_mnd_parse (hdr,dat)))
else if hdr' == csv_mndd_hdr
then mndd_to_wseq (csv_mndd_parse (hdr,dat))
else error "csv_midi_read_wseq: not MND or MNDD"
_ -> error "csv_midi_read_wseq: header?"
csv_midi_read_wseq :: (Read t,Real t,Read n,Real n) => FilePath -> IO (T.Wseq t (Event n))
csv_midi_read_wseq = fmap csv_midi_parse_wseq . load_csv