\begin{code} 
-- | 
-- Maintainer : silva.samuel@alumni.uminho.pt
-- Stability  : experimental
-- Portability: portable
-- This module implements lite interface to Haskore
--
-- Bugs: 
--  - Chords
--  - more than one Divisions(changes duration)
module Music.Analysis.MusicXML2Haskore where
--import Music.Analysis.Base 
--import Music.Analysis.PF (p1, p2, (><), grd)
--import Music.Analysis.Settings (union)
--import Music.Analysis.Motive (Motive, toMotive, fromMotive)
import Music.Analysis.PF 
--    cataMotive, splitMotiveList)
--import Music.Analysis.Melodic (MelodicNode)
--import Music.Analysis.Rhythm (RhythmNode)
--import Music.Analysis.Zip (VoiceZipNode)
--import Music.Analysis.Voices (MultiVoiceNode)
--import Music.Analysis.Instruments (MultiInstrumentNode, settings)
--import Haskore (Music(..), Pitch, Dur, PitchClass)
--import Haskore.Basics (Music(..), Pitch, Dur, PitchClass(..))
--import Haskore.Performance ()
import qualified Haskore ()
import qualified Haskore.Music as HMusic
import qualified Haskore.Basic.Pitch as HPitch
--import qualified Haskore.Basic.Duration as HDuration
import qualified Haskore.Melody as HMelody
--import qualified Haskore.Melody.Standard as HMelodyStd
--import qualified Haskore.Music.Rhythmic as HRhythmic
import qualified Haskore.Music.GeneralMIDI as GeneralMIDI
import qualified Medium.Controlled.List as Medium
import qualified Haskore.Interface.MIDI.Render as Render
--import qualified Haskore.Performance 
import Data.List
import Data.Maybe
--import Data.Function (const, (.))
--import Data.Either (either)
--import Data.Maybe (Maybe(..), isNothing)
--import Data.Tuple (uncurry)
import Numeric.NonNegative.Wrapper as NonNeg
import qualified Music.Analysis.MusicXML as IMusicXML
import qualified Music.Analysis.MusicXML.Level5 as Layer5
import qualified Music.Analysis.MusicXML.Level1 as Layer1
import qualified Text.XML.MusicXML as MusicXML 
import qualified Text.XML.MusicXML.Partwise as Partwise
--import Data.Ratio
import System.Info
import System.Cmd
import System.Exit
import Prelude
\end{code} \begin{code} 
-- |
from_Score_Partwise :: MusicXML.Score_Partwise -> MusicXML.Score_Partwise
from_Score_Partwise = (id >< (id >< fmap from_Part))
-- |
from_Part :: Partwise.Part -> Partwise.Part
from_Part = (id >< fmap from_Measure)
-- |
from_Measure :: Partwise.Measure -> Partwise.Measure
from_Measure = (id >< fmap from_Music_Data)
-- |
from_Music_Data :: MusicXML.Music_Data_ -> MusicXML.Music_Data_
from_Music_Data (MusicXML.Music_Data_1 x) = 
    MusicXML.Music_Data_1 (from_Note x)
from_Music_Data (MusicXML.Music_Data_2 x) = MusicXML.Music_Data_2 x
from_Music_Data (MusicXML.Music_Data_3 x) = MusicXML.Music_Data_3 x
from_Music_Data (MusicXML.Music_Data_4 x) = MusicXML.Music_Data_4 x
from_Music_Data (MusicXML.Music_Data_5 x) = MusicXML.Music_Data_5 x
from_Music_Data (MusicXML.Music_Data_6 x) = MusicXML.Music_Data_6 x
from_Music_Data (MusicXML.Music_Data_7 x) = MusicXML.Music_Data_7 x
from_Music_Data (MusicXML.Music_Data_8 x) = MusicXML.Music_Data_8 x
from_Music_Data (MusicXML.Music_Data_9 x) = MusicXML.Music_Data_9 x
from_Music_Data (MusicXML.Music_Data_10 x) = MusicXML.Music_Data_10 x
from_Music_Data (MusicXML.Music_Data_11 x) = MusicXML.Music_Data_11 x
from_Music_Data (MusicXML.Music_Data_12 x) = MusicXML.Music_Data_12 x
from_Music_Data (MusicXML.Music_Data_13 x) = MusicXML.Music_Data_13 x
-- |
from_Note :: MusicXML.Note -> MusicXML.Note
from_Note = id -- (id >< ((\(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13) -> 
----    x4' <- fmap abst_Type x4
--        (abst_Note_ x1, fmap abst_Instrument x2, 
--             abst_Editorial_Voice x3,
--             (maybe Nothing id . fmap from_Type) x4, fmap from_Dot x5, 
--             (maybe Nothing id . fmap from_Accidental) x6,
--             fmap from_Time_Modification x7, fmap from_Stem x8,
--             fmap from_Notehead x9, fmap from_Staff x10, fmap from_Beam x11,
--             fmap from_Notations x12, fmap from_Lyric x13))))
\end{code} \begin{code} 
-- |
group_Part :: Partwise.Part -> [[[[MusicXML.Note]]]]
group_Part =
    fmap (concat . group_Measure) . p2
-- |
group_Measure :: Partwise.Measure -> [[[[MusicXML.Note]]]]
group_Measure = 
    (fmap . fmap) (groupBy group_Instrument . sortBy cmp_Instrument) . 
    fmap (groupBy group_Staff . sortBy cmp_Staff) . 
    groupBy group_Voice . sortBy cmp_Voice .
    toNote . p2
-- |
toNote :: [MusicXML.Music_Data_] -> [MusicXML.Note]
toNote = catMaybes . fmap f
    where f (MusicXML.Music_Data_1 x) = return x
          f _ = fail []
-- |
group_Music_Data_ :: (MusicXML.Note -> MusicXML.Note -> Bool) ->
    MusicXML.Music_Data_ -> MusicXML.Music_Data_ -> Bool
group_Music_Data_ p (MusicXML.Music_Data_1 x) (MusicXML.Music_Data_1 y) = p x y
group_Music_Data_ _ _ _ = False
-- |
group_Instrument :: MusicXML.Note -> MusicXML.Note -> Bool
group_Instrument = (\ (_,(_,x2,_,_,_,_,_,_,_,_,_,_,_)) 
    (_,(_,y2,_,_,_,_,_,_,_,_,_,_,_)) -> x2 == y2)
-- |
group_Voice :: MusicXML.Note -> MusicXML.Note -> Bool
group_Voice = (\ (_,(_,_,(_,_,x3),_,_,_,_,_,_,_,_,_,_)) 
    (_,(_,_,(_,_,y3),_,_,_,_,_,_,_,_,_,_)) -> x3 == y3)
-- |
group_Staff :: MusicXML.Note -> MusicXML.Note -> Bool
group_Staff = (\ (_,(_,_,_,_,_,_,_,_,_,x10,_,_,_)) 
    (_,(_,_,_,_,_,_,_,_,_,y10,_,_,_)) -> x10 == y10)
-- |
cmp_Instrument :: MusicXML.Note -> MusicXML.Note -> Ordering
cmp_Instrument = (\ (_,(_,x2,_,_,_,_,_,_,_,_,_,_,_)) 
    (_,(_,y2,_,_,_,_,_,_,_,_,_,_,_)) -> x2 `compare` y2)
-- |
cmp_Voice :: MusicXML.Note -> MusicXML.Note -> Ordering
cmp_Voice = (\ (_,(_,_,(_,_,x3),_,_,_,_,_,_,_,_,_,_)) 
    (_,(_,_,(_,_,y3),_,_,_,_,_,_,_,_,_,_)) -> x3 `compare` y3)
-- |
cmp_Staff :: MusicXML.Note -> MusicXML.Note -> Ordering
cmp_Staff = (\ (_,(_,_,_,_,_,_,_,_,_,x10,_,_,_)) 
    (_,(_,_,_,_,_,_,_,_,_,y10,_,_,_)) -> x10 `compare` y10)
-- |
get_Instrument :: MusicXML.Note -> Maybe MusicXML.Instrument
get_Instrument (_,(_,x2,_,_,_,_,_,_,_,_,_,_,_)) = x2
-- |
get_Voice :: MusicXML.Note -> Maybe MusicXML.Voice
get_Voice (_,(_,_,(_,_,x3),_,_,_,_,_,_,_,_,_,_)) = x3
-- |
get_Staff :: MusicXML.Note -> Maybe MusicXML.Staff
get_Staff (_,(_,_,_,_,_,_,_,_,_,x10,_,_,_)) = x10
\end{code} \begin{code} 
-- |
group_Measure' :: Partwise.Measure -> 
    [(Maybe MusicXML.Instrument, 
        [(Maybe MusicXML.Staff, 
            [(Maybe MusicXML.Voice, [MusicXML.Note])])])]
group_Measure' = 
    map (id >< map (id >< map (split (headM . map get_Voice) id))) .
    map (id >< map (split ((headM.headM) . (map.map) get_Staff) id)) .
    map (split ((headM.headM.headM) . (map.map.map) get_Instrument) id) .
    group_Measure
-- |
headM :: Monad m => [m a] -> m a
headM [] = fail "empty list"
headM (x:_) = x
\end{code} \begin{code} 
-- |
toMedium_ :: [[[[Medium.T control a]]]] -> Medium.T control a
toMedium_ = 
    Medium.parallel .
    ((map) Medium.parallel) .
    ((map . map) Medium.parallel) .
    ((map . map . map) Medium.serial) 
-- |
toMedium :: [[[[a]]]] -> Medium.T control a
toMedium = 
    Medium.parallel .
    ((map) Medium.parallel) .
    ((map . map) Medium.parallel) .
    ((map . map . map) Medium.serial) .
    (map . map . map . map) Medium.prim

--toMedium' :: [[[[a]]]] -> Medium.T () a
--toMedium' = 
--    (Medium.Control () . Medium.parallel) .
--    ((map) (Medium.Control () . Medium.parallel)) .
--    ((map . map) (Medium.Control () . Medium.parallel)) .
--    ((map . map . map) (Medium.Control () . Medium.serial)) .
--    (map . map . map . map) Medium.prim
-- |
toMedium' :: [(Maybe MusicXML.Instrument, 
        [(Maybe MusicXML.Staff, 
            [(Maybe MusicXML.Voice, [MusicXML.Note])])])] -> 
                Medium.T ControlID MusicXML.Note
toMedium' = 
    Medium.parallel .
    (map (uncurry Medium.Control . 
        (Control_Instrument >< Medium.parallel))) . 
    (map (id >< map (uncurry Medium.Control . 
        (Control_Staff >< Medium.parallel)))) . 
    (map (id >< map (id >< map (uncurry Medium.Control . 
        (Control_Voice >< Medium.serial))))) . 
    (map (id >< map (id >< map (id >< map Medium.prim)))) . 
    id
--    where ctrl = Medium.Control 
-- |
data ControlID = Control_Instrument (Maybe MusicXML.Instrument) 
               | Control_Staff (Maybe MusicXML.Staff) 
               | Control_Voice (Maybe MusicXML.Voice) 
               deriving (Eq, Show)
\end{code} \begin{code} 
-- |
abst_Step :: MusicXML.Step -> Maybe Layer1.Step
abst_Step = IMusicXML.abst_Step
-- |
abst_Octave :: MusicXML.Octave -> Layer1.Octave
abst_Octave = IMusicXML.abst_Octave
-- |
abst_Alter :: MusicXML.Alter -> Maybe Layer1.Alter
abst_Alter = IMusicXML.abst_Alter
-- |
toClass :: Layer1.Step -> Maybe Layer1.Alter -> HPitch.Class
toClass step Nothing = toEnum (3*(fromEnum step) + 1)
toClass step (Just alter) = 
    toEnum (3*(fromEnum step) + 1 + (truncate ((3/2)*alter)))
-- |
abst_Pitch :: MusicXML.Pitch -> (Layer1.Octave, HPitch.Class)
abst_Pitch = 
    swap . (uncurry toClass >< id) . unflatl . IMusicXML.abst_Pitch
-- |
abst_Full_Note_ :: MusicXML.Full_Note_ -> Maybe HPitch.T
abst_Full_Note_ (MusicXML.Full_Note_1 x) = return (abst_Pitch x)
abst_Full_Note_ _                        = fail []
-- |
abst_Full_Note :: MusicXML.Full_Note -> Maybe HPitch.T
abst_Full_Note = abst_Full_Note_ . p2
-- |
abst_Note_ :: MusicXML.Note_ -> (Maybe HPitch.T, Maybe Layer5.Duration)
abst_Note_ (MusicXML.Note_1 _) = (Nothing, Nothing)
abst_Note_ (MusicXML.Note_2 x) = 
    ((abst_Full_Note >< Just . abst_Duration) . p2 . unflatr) x
--    in maybe Nothing (\a' -> return (a', b)) a
abst_Note_ (MusicXML.Note_3 x) = 
    ((abst_Full_Note >< Just . abst_Duration) . p1 . unflatl) x
--    in maybe Nothing (\a' -> return (a', b)) a
-- |
abst_Duration :: MusicXML.Duration -> Layer5.Duration
abst_Duration = IMusicXML.abst_Duration
-- |
toDur :: Layer5.Duration -> HMusic.Dur
toDur n = NonNeg.fromNumber (fromIntegral n)
-- |
abst_Note :: MusicXML.Note -> HMusic.T HPitch.T
abst_Note (_,(a,_,_,_,_,_,_,_,_,_,_,_,_)) = 
    case abst_Note_ a of
        (Just a1, Just a2) -> HMusic.atom (toDur a2) (Just a1)
        (Nothing, Just a2) -> HMusic.rest (toDur a2) 
        (_,Nothing) -> HMusic.rest 0
-- |
abst_Note' :: MusicXML.Note -> HMelody.T MusicXML.Note 
abst_Note' n@(_,(a,_,_,_,_,_,_,_,_,_,_,_,_)) = 
    case abst_Note_ a of
        (Just a1, Just a2) -> HMusic.atom (toDur a2) (Just (HMelody.Note n a1))
        (Nothing, Just a2) -> HMusic.rest (toDur a2)
        (_,Nothing) -> HMusic.rest 0 
--        Just (a1,a2) -> Just (toDur a2, a1)
--        Nothing -> Nothing

--map_abst_Note (a,b,c) = 
--(id >< fmap swap) . split id abst_Note'
\end{code} \begin{code} 
-- |
measure2haskore :: Partwise.Measure -> HMelody.T MusicXML.Note
measure2haskore = toMedium_ . (map.map.map.map) abst_Note' . group_Measure
-- |
part2haskore :: Partwise.Part -> HMelody.T MusicXML.Note
part2haskore = Medium.Serial . map measure2haskore . p2
-- |
partwise2haskore :: Partwise.Score_Partwise -> HMelody.T MusicXML.Note
partwise2haskore = Medium.Parallel . fmap part2haskore . p2 . p2

toMidi :: MusicXML.MusicXMLDoc -> GeneralMIDI.T
toMidi (MusicXML.Score (MusicXML.Partwise music)) = 
    (GeneralMIDI.fromMelodyNullAttr GeneralMIDI.AcousticGrandPiano . 
    fmap fun . partwise2haskore) music
    where fun (HMusic.Atom x Nothing) = HMusic.Atom x Nothing
          fun (HMusic.Atom x (Just (HMelody.Note _ y))) = 
            HMusic.Atom x (Just (HMelody.Note () y))
toMidi (_) = 
    (GeneralMIDI.fromMelodyNullAttr GeneralMIDI.AcousticGrandPiano . 
    fmap fun . Medium.Parallel) []
    where fun (HMusic.Atom x Nothing) = HMusic.Atom x Nothing
          fun (HMusic.Atom x (Just (HMelody.Note _ y))) = 
            HMusic.Atom x (Just (HMelody.Note () y))

saveMidi :: FilePath -> GeneralMIDI.T -> IO ()
saveMidi filepath = Render.fileFromGeneralMIDIMusic filepath 

playMidi :: FilePath -> GeneralMIDI.T -> IO ExitCode
playMidi filepath music = 
    Render.fileFromGeneralMIDIMusic filepath music >> playGeneric filepath
    
playGeneric :: FilePath -> IO ExitCode
playGeneric filepath = 
    case System.Info.os of
        "mingw32" -> rawSystem "mplay32" [filepath] 
        "linux" ->  rawSystem "playmidi" ["-rf", filepath]
        _ ->        rawSystem "timidity" ["-B8,9", filepath]
\end{code} \begin{nocode} -- > play cmd opts m = -- > do fileFromGeneralMIDIMusic fileName m -- > rawSystem cmd (opts ++ [fileName]) -- > return () -- GeneralMIDI.fromMelodyNullAttr GeneralMIDI.AcousticGrandPiano . -- fmap fun . partwise2haskore -- where fun (HMusic.Atom x Nothing) = HMusic.Atom x Nothing -- fun (HMusic.Atom x (Just (HMelody.Note _ y))) = -- HMusic.Atom x (Just (HMelody.Note () y)) --fromStdMelody instr = HMusic.mapNote (noteFromStdMelodyNote instr) -- > noteFromStdMelodyNote :: instr -> StdMelody.Note -> Note drum instr --noteFromAttrs nas = HRhythmic.Note (Accessor.get StdMelody.velocity1 nas) --noteFromStdMelodyNote instr (HMelody.Note nas p) = noteFromAttrs nas (HRhythmic.Tone instr p) \end{nocode} \begin{nocode} -- || input Music from Haskore input :: Music -> Motive MultiInstrumentNode input (Note p d _) = mkMotive settings [[(((inputPitch p,inputDur d),1),[])]] input (Rest d) = mkMotive settings [[(((Nothing, inputDur d), 1),[])]] input (m1 :+: m2) = seq (input m1) (input m2) input (m1 :=: m2) = par (input m1) (input m2) input (Instr _ m) = input m input (Player _ m) = input m input _ = mkMotive settings [] \end{nocode} \begin{nocode} -- || inputPitch :: Pitch -> MelodicNode inputPitch = (const (Just (0,0))) . p1 -- || inputDur :: Dur -> RhythmNode inputDur = const (1,0) \end{nocode} \begin{nocode} -- | par :: Motive a -> Motive a -> Motive a par m1 m2 = let (s1, l1) = fromMotive m1 (s2, l2) = fromMotive m2 in toMotive ((s1`union`s2), (l1 ++ l2)) -- | BUG seq :: Motive a -> Motive a -> Motive a seq m1 m2 = let (s1, l1) = fromMotive m1 (s2, l2) = fromMotive m2 in toMotive ((s1`union`s2), (l1 ++ l2)) \end{nocode} \begin{nocode} --output :: Motive MultiInstrumentNode -> Music --output = outputInstrument outputInstrument :: Motive MultiInstrumentNode -> [Motive MultiInstrumentNode] outputInstrument = mapL (toMotive . outputVoice) . splitMotiveList -- uncurry -- (maybe "Piano" id . getText "Instrument" >< id) . -- cataMotive [] (\s -> uncurry (:) . (outputVoice >< id)) -- fromMotive --outputVoice :: Motive MultiVoiceNode -> Motive MultiVoiceNode outputVoice = cataMotive [] (\s -> uncurry (:) . (id >< id)) --outputZip :: Motive VoiceZipNode -> Motive VoiceZipNode outputZip = cataMotive [] (\s -> uncurry (:)) \end{nocode} \begin{nocode} inRest :: RhythmNode -> Music inRest = Rest . uncurry (%) . (toInteger >< toInteger) inNote :: VoiceZipNode -> Music inNote = either (f . p2) (uncurry g) . grd (isNothing . p1) where f = (Rest . uncurry (%) . (toInteger >< toInteger)) g p d = Note ((const (C,0)) p) ((uncurry (%) . (toInteger >< toInteger)) d) [] \end{nocode}