-- <PRE>

import Music
import Ratio
import System(system)

-- Be sure and maker HUGS look in the directory where the
-- Haskore module code is stored using the "path" mechanism
import Haskore(outputMidiFile, midiFileToString,MidiFile(..)
              ,Division(..),MEvent(..),MidiEvent(..),MidiChannel(..)
              ,ProgNum(..),MetaEvent(..))


cScale1 =
  line [c 4 qn , d 4 qn , e 4 qn ,
        f 4 qn , g 4 qn , a 4 qn ,
		   b 4 qn , c 5 qn]

---------------------
type Performance = [Event]

data Event =
   Event { eTime :: Time,      -- start time
           eInst :: IName,     -- instrument
           ePitch :: AbsPitch, -- pitch or note
           eDur  :: DurT }     -- duration
     deriving (Eq,Ord,Show)

type Time      = Float
type DurT      = Float

-----------------------------
ratioToFloat  :: Ratio Int -> Float
ratioToFloat r = intToFloat (numerator r) / intToFloat (denominator r)

intToFloat :: Int -> Float

intToFloat  = fromInteger . toInteger


data Context = Context { cTime :: Time, cInst :: IName,
                         cDur  :: DurT, cKey  :: Key }
     deriving Show

type Key     = AbsPitch

metro :: Float -> Dur -> DurT
metro setting dur = 60 / (setting * ratioToFloat dur)

--------------------------------------------------

performSimple c@(Context t i dt k) m =
 case m of
   Note p d    -> let dur = ratioToFloat d * dt
                  in [Event t i (transpose p k i) dur]
   Rest d      -> []
   m1 :+: m2   ->
      performSimple c m1 ++
      performSimple (c {cTime = t + ratioToFloat (dur m1) * dt}) m2
   m1 :=: m2   -> merge (performSimple c m1) (performSimple c m2)
   Tempo  a  m ->
      performSimple (c {cDur = dt / ratioToFloat a} ) m
   Trans  p  m -> performSimple (c {cKey = k + p} ) m
   Instr  nm m -> performSimple (c {cInst = nm} ) m
 where transpose p k Percussion = absPitch p
       transpose p k _          = absPitch p + k

merge :: Performance -> Performance -> Performance

merge a@(e1:es1) b@(e2:es2) =
  if eTime e1 < eTime e2 then e1 : merge es1 b
                         else e2 : merge a es2
merge [] es2 = es2
merge es1 [] = es1

--------------------------------

perform :: Context -> Music -> Performance
perform c m = fst (perf c m)

perf :: Context -> Music -> (Performance, DurT)
perf c@(Context t i dt k) m =
  case m of
    Note p d     -> let dur = ratioToFloat d * dt
                    in ([Event t i (transpose p k i) dur], dur)
    Rest d       -> ([], ratioToFloat d * dt)
    m1 :+: m2    -> let (pf1,d1) = perf c m1
                        (pf2,d2) = perf (c {cTime = t+d1} ) m2
                    in (pf1++pf2, d1+d2)
    m1 :=: m2    -> let (pf1,d1) = perf c m1
                        (pf2,d2) = perf c m2
                    in (merge pf1 pf2, max d1 d2)
    Tempo  a  m  -> perf (c {cDur = dt / ratioToFloat a} ) m
    Trans  p  m  -> perf (c {cKey = k + p} ) m
    Instr  nm m  -> perf (c {cInst = nm} ) m
  where transpose p k Percussion = absPitch p
        transpose p k _          = absPitch p + k

-------------------------------------------------------
{- Defined in module Haskore
data MidiFile = MidiFile MFType Division [Track]
      deriving (Show, Eq)

type MFType = Int
type Track  = [MEvent]

data Division = Ticks Int | SMPTE Int Int
      deriving (Show,Eq)

data MEvent = MidiEvent ElapsedTime MidiEvent
             | MetaEvent ElapsedTime MetaEvent
             | NoEvent
      deriving (Show,Eq)

type ElapsedTime  = Int
-}

-------------------------------
{- Defined in Module Haskore
data MidiEvent = NoteOff    MidiChannel MPitch Velocity
                | NoteOn     MidiChannel MPitch Velocity
                | ProgChange MidiChannel ProgNum
             -- | ...
      deriving (Show, Eq)

type MPitch      = Int
type Velocity    = Int
type ProgNum     = Int
type MidiChannel = Int

-- Meta Events
data MetaEvent = SetTempo MTempo
            -- | ...
     deriving (Show, Eq)

type MTempo      = Int
-}
--------------------------------------

performToMidi :: Performance -> MidiFile
performToMidi pf =
  MidiFile mfType (Ticks division)
                  (map performToMEvs (splitByInst pf))

mfType   = 1 :: Int
division = 96 :: Int

partition :: (a -> Bool) -> [a] -> ([a],[a])
partition p xs =
  foldr select ([],[]) xs
        where select x (ts,fs)
                 | p x       = (x:ts,fs)
                 | otherwise = (ts, x:fs)

splitByInst :: Performance ->[(MidiChannel,ProgNum,Performance)]
splitByInst p
  = aux 1 {-  used to be 0 -} p where
      aux n [] = []
      aux n pf =
        let i         = eInst (head pf)
            (pf1,pf2) = partition (\e -> eInst e == i) pf
            n'        = if n==8 then 10 else n+1
        in if i==Percussion
              then (9, 0, pf1) : aux n pf2
              else
                if n>15
                   then error
                        "No more than 16 instruments allowed"
                   else (n, fromEnum i, pf1) : aux n' pf2


performToMEvs :: (MidiChannel,ProgNum,Performance) -> [MEvent]

performToMEvs (ch,pn,perf)
  = let setupInst   = MidiEvent 0 (ProgChange ch pn)
        setTempo    = MetaEvent 0 (SetTempo tempo)
        loop []     = []
        loop (e:es) =
           let (mev1,mev2) = mkMEvents ch e
           in  mev1 : insertMEvent mev2 (loop es)
    in  setupInst : setTempo : loop perf

tempo :: Int
tempo = 500000


--------------------------------------
insertMEvent :: MEvent -> [MEvent] -> [MEvent]

insertMEvent ev1  []  = [ev1]
insertMEvent ev1@(MidiEvent t1 _) evs@(ev2@(MidiEvent t2 _):evs')
  = if t1 <= t2 then ev1 : evs
                else ev2 : insertMEvent ev1 evs'

mkMEvents :: MidiChannel -> Event -> (MEvent,MEvent)

mkMEvents mChan (Event { eTime = t,
                         ePitch = p,
                         eDur = d })
   = (MidiEvent (toDelta t)    (NoteOn  mChan p 127),
      MidiEvent (toDelta (t+d))(NoteOff mChan p 127))

toDelta t = round (t * 4.0 * intToFloat division)

-----------------------------------------------------

test :: Music -> IO ()
test m = outputMidiFile "test.mid"
           (performToMidi (perform defCon m))


defCon :: Context  -- Defauult Initial Context
defCon = Context { cTime   = 0,
                   cInst   = AcousticGrandPiano,
                   cDur    = metro 120 qn,
                   cKey    = 0 }

{-
defCon :: Context
defCon = Context { cTime   = 0
                 --, cPlayer = fancyPlayer
                 , cInst   = "piano"
                 , cDur    = metro 120 qn
        		 , cKey    = 0
          		 -- , cVol    = 127
          		 }


-}

testWin95 m =
  do { test m
     ; system "mplayer test.mid"
     ; return () }

testNT    m =
  do { test m
     ; system "mplay32 test.mid"
     ; return ()}

testLinux m =
  do { test m
     ;  system "playmidi -rf test.mid"
     ; return ()}



m1 = cScale1 :=: (revM (Tempo 2 (delay wn cScale1)))

main = testNT m1

-- </PRE>