{-

This is a transcription of the code from Chapter 4 of FOP,
"Describing and Interpreting Music in Haskell".  There are
only two differences:

1) All instances of "Ratio Int" have been changed to "Ratio Integer",
   to make it more accurate and thus suitable for conversion to Midi.

2) Some code has been added at the end to allow converting Music values
   into Midi files.  To enable it, uncomment it (and the module imports
   at the top) - this requires first installing Haskore, from which
   several Midi data types and functions are borrowed.

If you are really serious about doing computer music in Haskell, you
are better off using the full Haskore library.  But this file is a
great introduction, as described in Chapter 4 of FOP.

-}


module Music where

import Prelude hiding (mapM)
import Ratio
import qualified Numeric as N

{-
import qualified HaskToMidi as H   -- from Haskore library
import qualified Performance as P  -- from Haskore library
-}

-- Section 4.2
--------------

type Pitch      = (PitchClass, Octave) 

data PitchClass = Cf | C | Cs | Df | D | Ds | Ef | E | Es | Ff | F 
                | Fs | Gf | G | Gs | Af | A | As | Bf | B | Bs 
                  deriving (Show,Eq) 

type Octave     = Int

data Note = Rest Dur
          | Note Pitch Dur
     deriving (Show, Eq)

type Dur   = Ratio Integer

data Music = Prim Note 
           | Music :+: Music   
           | Music :=: Music   
           | Tempo (Ratio Integer) Music 
           | Trans Int Music  
     deriving (Show, Eq)

type AbsPitch = Int

absPitch :: Pitch -> AbsPitch
absPitch (pc,oct) = 12*oct + pcToInt pc

pitch    :: AbsPitch -> Pitch
pitch ap = ( [C,Cs,D,Ds,E,F,Fs,G,Gs,A,As,B] !! mod ap 12,
             quot ap 12 )

pcToInt :: PitchClass -> Int
pcToInt pc = case pc of
  Cf -> -1 ;    C ->  0 ;    Cs ->  1 
  Df ->  1 ;    D ->  2 ;    Ds ->  3 
  Ef ->  3 ;    E ->  4 ;    Es ->  5 
  Ff ->  4 ;    F ->  5 ;    Fs ->  6 
  Gf ->  6 ;    G ->  7 ;    Gs ->  8 
  Af ->  8 ;    A ->  9 ;    As ->  10
  Bf -> 10 ;    B -> 11 ;    Bs ->  12

trans    :: Int -> Pitch -> Pitch
trans i p = pitch (absPitch p + i)

cf,c,cs,df,d,ds,ef,e,es,ff,f,fs,gf,g,gs,af,a,as,bf,b,bs 
     :: Octave -> Dur -> Music
cf o d = Prim (Note (Cf,o) d) ; c  o d = Prim (Note (C, o) d)
cs o d = Prim (Note (Cs,o) d) ; df o d = Prim (Note (Df,o) d)
d  o d = Prim (Note (D, o) d) ; ds o d = Prim (Note (Ds,o) d)
ef o d = Prim (Note (Ef,o) d) ; e  o d = Prim (Note (E, o) d)
es o d = Prim (Note (Es,o) d) ; ff o d = Prim (Note (Ff,o) d)
f  o d = Prim (Note (F, o) d) ; fs o d = Prim (Note (Fs,o) d)
gf o d = Prim (Note (Gf,o) d) ; g  o d = Prim (Note (G, o) d)
gs o d = Prim (Note (Gs,o) d) ; af o d = Prim (Note (Af,o) d)
a  o d = Prim (Note (A, o) d) ; as o d = Prim (Note (As,o) d)
bf o d = Prim (Note (Bf,o) d) ; b  o d = Prim (Note (B, o) d)
bs o d = Prim (Note (Bs,o) d)

wn, hn, qn, en, sn, tn, dhn, dqn, den, dsn           :: Dur
wnr, hnr, qnr, enr, snr, tnr, dhnr, dqnr, denr, dsnr :: Music
wn  = 1    ; wnr  = Prim (Rest  wn) -- whole
hn  = 1%2  ; hnr  = Prim (Rest  hn) -- half
qn  = 1%4  ; qnr  = Prim (Rest  qn) -- quarter
en  = 1%8  ; enr  = Prim (Rest  en) -- eighth
sn  = 1%16 ; snr  = Prim (Rest  sn) -- sixteenth
tn  = 1%32 ; tnr  = Prim (Rest  tn) -- thirty-second
dhn = 3%4  ; dhnr = Prim (Rest dhn) -- dotted half
dqn = 3%8  ; dqnr = Prim (Rest dqn) -- dotted quarter
den = 3%16 ; denr = Prim (Rest den) -- dotted eighth
dsn = 3%32 ; dsnr = Prim (Rest dsn) -- dotted sixteenth

line, chord :: [Music] -> Music
line  = foldr (:+:) (Prim (Rest 0))
chord = foldr (:=:) (Prim (Rest 0))

cMaj = [ n 4 qn | n <- [c,e,g] ] 

cMajArp = line  cMaj 
cMajChd = chord cMaj 

delay, pDelay :: Dur -> Music -> Music 
delay  d m = Prim (Rest d) :+: m
pDelay d m = m :+: Prim (Rest d)

repeatM  :: Music -> Music 
repeatM m = m :+: repeatM m 

trill :: Int -> Dur -> Music -> Music
trill i d n@(Prim (Note p nd)) = 
  if d >= nd then n
  else Prim (Note p d) :+: trill (negate i) d
                                 (Prim (Note (trans i p) (nd-d))) 

trill _ _ _ = error "Trill input must be a single note"

trill'         :: Int -> Dur -> Music -> Music
trill' i d n@(Prim (Note p nd)) = 
  trill (negate i) d (Prim (Note (trans i p) nd))

trilln  :: Int -> Int -> Music -> Music
trilln i nTimes m = trill i (durM m / (toInteger nTimes % 1)) m

trilln' :: Int -> Int -> Music -> Music
trilln' i nTimes m = trilln (negate i) nTimes (Trans i m)

rolln   :: Int -> Music -> Music
rolln nTimes m = trilln 0 nTimes m

ssfMelody :: Music
ssfMelody = m1 :+: m2 :+: m3 :+: m4
m1 = trilln 2 5 (bf 6 en) 
     :+: line [ef 7 en, ef 6 en, ef 7 en]
m2 = line [bf 6 sn, c 7 sn, bf 6 sn, g 6 sn, ef 6 en, bf 5 en]
m3 = line [ef 6 sn, f 6 sn, g 6 sn, af 6 sn, bf 6 en, ef 7 en]
m4 = trill 2 tn (bf 6 qn) :+: bf 6 sn :+: denr

-- Section 4.3
--------------

durM :: Music -> Dur
durM (Prim (Note _ d)) = d
durM (Prim (Rest d))   = d
durM (m1 :+: m2)       = durM m1   +   durM m2
durM (m1 :=: m2)       = durM m1 `max` durM m2
durM (Tempo  a  m)     = durM m / a
durM (Trans  _  m)     = durM m

revM :: Music -> Music
revM n@(Prim _)    = n
revM (m1 :+: m2)   = revM m2 :+: revM m1
revM (m1 :=: m2)   = revM m1 :=: revM m2
revM (Tempo a  m)  = Tempo a (revM m)
revM (Trans i  m)  = Trans i (revM m)

tn0 = c 1 2

tm1 = (c 1 1 :+: ((d 1 2 :=: e 1 3) :+: f 1 4))
tm2 = ((c 1 1 :+: (d 1 2 :=: e 1 3)) :+: f 1 4)
tm3 = tn0 :+: tn0 :+: tn0 :+: tn0
tm4 = (d 1 2 :=: e 1 3) :+: f 1 4
tm5 =  d 1 2 :=: e 1 3

trev1 = revM tm1
trev2 = revM tm2

mapM :: (Note -> Note) -> Music -> Music
mapM f (Prim n)      = Prim (f n)
mapM f (m1 :+: m2)   = mapM f m1 :+: mapM f m2
mapM f (m1 :=: m2)   = mapM f m1 :=: mapM f m2
mapM f (Tempo r m)   = Tempo r (mapM f m)
mapM f (Trans p m)   = Trans p (mapM f m)

tmap1 = mapM foo trev1
tmap2 = mapM foo trev2

foo (Note (D,1) 2) = Rest 2
foo n              = n

pad :: Music -> Music -> Music
pad m1 m2 =
  let d1 = durM m1
      d2 = durM m2
      pd = abs (d2 - d1) / 2
  in case (compare d2 d1) of
       GT -> delay pd (pDelay pd m1) :=: m2
       EQ -> m1 :=: m2
       LT -> m1 :=: delay pd (pDelay pd m2)  

padM            :: Music -> Music
padM n@(Prim _)  = n
padM (m1 :+: m2) = padM m1 :+: padM m2
padM (Tempo r m) = Tempo r (padM m)
padM (Trans p m) = Trans p (padM m)
padM (m1 :=: m2) = pad (padM m1) (padM m2)

tpad = padM tm1

takeM             :: Dur -> Music -> Music
takeM d m | d <= 0 = Prim (Rest 0)
takeM d m          = takM d (padM m)

takM                      :: Dur -> Music -> Music
takM d (Prim (Note p d0)) = Prim (Note p (min d0 d))
takM d (Prim (Rest d0))   = Prim (Rest (min d0 d))
takM d (m1 :=: m2)        = takM d m1 :=: takM d m2
takM d (Tempo a m)        = Tempo a (takM (d*a) m)
takM d (Trans a m)        = Trans a (takM d m)
takM d (m1 :+: m2)        = 
  let d1 = durM m1
  in if d <= d1 then takM d m1
                else m1 :+: takM (d-d1) m2

ttake d = takeM d tm1
tdrop d = dropM d tm1

dropM :: Dur -> Music -> Music
dropM d m = revM (takeM (durM m - d) (revM (padM m)))

tt1 d1 d2 m = (takeM d1 . takeM d2) m == takeM (min d1 d2) m
tt2 d1 d2 m = (dropM d1 . dropM d2) m == dropM (d1 + d2) m
tt3 d1 d2 m = (takeM d1 . dropM d2) m == (dropM d2 . takeM (d1 + d2)) m
tt4 d1 d2 m = (dropM d1 . takeM d2) m == (takeM (d2 - d1) . dropM d1) m
            -- if d2 >= d1

-- Section 4.4
--------------

type Performance = [Event]
 
data Event = Event { eTime :: Time,
                     ePitch :: AbsPitch,
                     eDur  :: DurT }  
     deriving (Eq,Ord,Show) 
 
type Time = Ratio Integer
type DurT = Ratio Integer

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

type Key = AbsPitch

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

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

perf :: Context -> Music -> Performance
perf c@(Context t dt k) m =
  case m of
    Prim (Note p d) -> [ Event t (absPitch p + k) (d * dt) ]
    Prim (Rest d)   -> []
    m1 :+: m2       -> perf c m1 ++ 
                       perf (c {cTime = t + (durM m1) * dt}) m2
    m1 :=: m2       -> merge (perf c m1) (perf c m2)
    Tempo  a  m     -> perf (c {cDur = dt / a}) m
    Trans  p  m     -> perf (c {cKey = k + p}) m

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

-- Test

tc0 = Context 0 1 0

ssfp  = perform tc0 ssfMelody


{-
-- Midi conversion
------------------

fopPerfToHaskPerf :: Performance -> P.Performance
fopPerfToHaskPerf = map fopEvToHaskEv
  where fopEvToHaskEv (Event t p d) = 
           P.Event (N.fromRat t) "" p (N.fromRat d) 100 []

perfToMidi :: Performance -> FilePath -> IO ()
perfToMidi p fp =
  let m = H.performToMidi (fopPerfToHaskPerf p) []
  in H.outputMidiFile fp m

ssfm  = perfToMidi ssfp "ssf.mid"

-}