> module Transition.Assignment4 where
>
> import Transition.Basics
> import Transition.Translate (toMelody, toMidi)
> import Haskore.Interface.MIDI.Render (playMidi)
> -- import qualified Haskore.Music.GeneralMIDI as GM
> -- import qualified Haskore.Music             as Music
> -- import qualified Haskore.Melody            as Melody
> -- import qualified Haskore.Music.Rhythmic    as RhyMusic
> import Random
> import Array
> import List

> out = playMidi . toMidi . Instr "Acoustic Grand Piano"

Problem 1
---------

Define  an  arpeggiator  function:  Given  a chord  represented  as  a
parallel  composition of equal-duration  notes, return  something that
approximates  its  arpeggiation, i.e.  the  playing  of  each note  in
succession until  all of them are  sounding as in  the original chord.
The duration of  the resultant arpeggiation should be  the same as the
duration of  the original chord.   Also, your function should  take an
argument to control the rate of arpeggiation.

Solution:

I will make the following assumptions:

a) The "rate" is the time (in whole notes) between the first and last
notes in the arpeggiated chord (and thus isn't really a "rate").  This
means that the time between each note depends on the number of notes
-- this seems to be the right solution to me, although it would have
been easier to assume that the rate is the time between each note.

b) The chord is created by an application of the "chord" function, and
therefore has the form:

Note p1 d [] :=: (Note p2 d :=: ( ... :=: (Note pn d) ... )) 

c) p1 < p2 < ... < pn, and thus p1 will be played first, consistent
with the standard notion of an arpeggio.

d) The Music type is a "Polymorphic Temporal Media" type, and thus has
things like "fold" defined on it.  Since this is in fact not the case
for the Music type defined in Transition.Basics, I define my own
version of fold here:

> foldM :: ((Pitch,Dur)->b) -> (b->b->b) -> (b->b->b)
>          -> Music -> b
> foldM f g h (Note p d _) = f (p,d)
> foldM f g h (m1 :+: m2) = 
>       foldM f g h m1 `g` foldM f g h m2
> foldM f g h (m1 :=: m2) = 
>       foldM f g h m1 `h` foldM f g h m2

The solution is then:

> arpeggiate :: Dur -> Music -> Music
> arpeggiate r m =
>	let d    = dur m
>	    pits = foldM (\(a,b)->[a]) seqErr (++) m
>	    del  = r / fromIntegral (length pits - 1)
>	    durs = iterate (subtract del) d
>	in if r >= d
>          then (error "arpeggio rate exceeds chord duration")
>	   else chord [Rest (d-d') :+: Note p d' [] | (p,d') <- zip pits durs]

> seqErr = error "not a chord"

Simple test of arpeggiator:

> arpTest = arpeggiate (1/16) (chord noteList)
> noteList = [ n 2 hn [] | n <- [c,e,g,b] ]

> t1 = Rest hn :+: chord noteList :+: Rest hn :+: arpTest

Problem 2
---------

Write Haskore programs to generate stochastic melodies based on the
following ideas:

a) Choose notes from a scale by selecting randomly using:
     a uniform random distribution, and
     some non-uniform distribution.

Solution:

"randSel rands xs" returns a list whose elements are from xs, chosen
randomly based on the elements of rands.

> randSel :: [Double] -> [a] -> [a]
> randSel rands xs =
>	let n = length xs
>	    indices = [ truncate (fromIntegral n * r) | r <- rands ]
>       in map (xs!!) indices

or, as a one-liner:

> randSel' rands xs =
>       map ((xs!!).truncate.(fromIntegral (length xs) *)) rands

We'll use two scale types:

> diatonicScale   = [c,d,e,f,g,a,b]
> chromaticScale  = [c,cs,d,ds,e,f,fs,g,gs,a,as,b]

The generated scale is then:

> genMela num scale rands =
>   line (take num [ n 2 sn [] | n <- randSel rands scale ])

Four tests:

> t2a1 = genMela 100 diatonicScale  randNums
> t2a2 = genMela 100 chromaticScale randNums
> t2a3 = genMela 100 diatonicScale  gaussNums
> t2a4 = genMela 100 chromaticScale gaussNums

b) Given a starting note, choose intervals (positive or negative) using:
     a uniform random distribution, and
     some non-uniform distribution.

Solution:

Let's choose intervals from the set:

> intervals :: [AbsPitch]
> intervals = [-5,-4,-3,-2,-1,0,1,2,3,4,5]

The generated scale is then:

> genMelb num start intervals rands =
>   let abspits = scanl (+) start (randSel rands intervals)
>   in line (take num [ Note (pitch p) sn [] | p <- abspits ])

Tests:

> t2b1 = genMelb 100 30 intervals randNums
> t2b2 = genMelb 100 30 intervals gaussNums

c) Choose notes using the following approximation to 1/f fractional
   noise: Start with an infinite list of random numbers.  The sum of
   the first n random numbers is the pitch of the first note.  Now
   generate a random number between 1 and n, and drop that many numbers
   from the list.  The next note is the sum of the first n numbers from
   the resulting list.  Repeat this process indefinitely.  Note that
   there are several control parameters in this algorithm:
     The number n, i.e. the length of the "history".
     The range of the random numbers in the list.
     The method of choosing the number of random numbers to drop at 
       each step in the algorithm.

Solution:

The heart of this algorithm is captured elegantly as:

> onef :: Num a => Int -> [a] -> [Int] -> [a]
> onef n rands1 rands2 =
>   map (sum . take n) (scanl (flip drop) rands1 rands2)

It can be used like this:

> genMelc num n rands1 rands2 =
>   let abspits = onef n rands1 rands2
>   in line (take num [ Note (pitch (p-10)) sn [] | p <- abspits ])

Random notes and drops:

> randPits :: Int -> [Int]
> randPits r = randomRs (0,r-1) (mkStdGen 36478)

> randDrops1, randDrops2 :: Int -> [Int]
> randDrops1 d = randomRs (0,d) (mkStdGen 12516)
> randDrops2 d = map (round . (fromIntegral d *) . (**2)) randNums

Tests:

> t2c1 r n = genMelc 100 n (randPits r) (randDrops1 n)
> t2c2 r n = genMelc 100 n (randPits r) (randDrops2 n)

For r and n, try 10 10, 5 10, and 5 5.

Random Numbers
--------------

> randNums :: [Double]
> randNums = randomRs (0,1) (mkStdGen 12345)

The numbers generated above from Haskell's random number generator are
(presumably) uniformally distributed between 0 and 1.  To generate a
Gaussian distribution from this uniform distribution, we could use the
idea presented in the text, namely the use of a *cumulative*
distribution function, i.e. the integral of the Gaussian.
Unfortunately, there is no closed-form formula for a Gaussian CDF.  So
we have to use numerical techniques.

[I'd like to do one better than what the text does by using the
*inverse* cumulative distribution, also called a "percent point
function", to directly redistribute the values from the normal
distribution.  Unfortunately I don't know exactly how to do this.  My
intuition tells that instead of integrating the Gaussian, I should
integrate 1 minus the Gaussian, but in the case where the peak of the
Gaussian is > 1, this doesn't work.  My attempt to normalize with
respect to the peak Gaussian value didn't work out right either.]

I will do the integration by creating a 1000-element Haskell array.
One can view the array as a "cache" of function values.

Haskell has a built-in function similar to foldl, called scanl:

scanl :: :: (a -> b -> a) -> a -> [b] -> [a]

such that, for example, scanl (+) 0 [1,2,3] = [0,1,3,6].  The cool
thing about scanl is that its very nature is a kind of discrete
integration.  We can use this to compute the cumulative Gaussian
distribution, as follows.  First, here's the definition of the
Gaussian distribution:

> gaussian :: Double -> Double -> Double -> Double
> gaussian mu sig x = 
>   exp ((-(x-mu)**2)/(2*sig**2)) / (sig * sqrt (2*pi))

where mu is the mean, and sig is the standard deviation, which for our
application is:

> mu  = 0.5  :: Double
> sig = 0.15 :: Double

Next we use scanl to generate the Gaussian cumulative distribution
function (gcdf), which we normalize and cache in an array:

> gcdf :: Array Int Double
> gcdf = let -- mx  = gaussian mu sig mu
>            vals = scanl (+) 0 (map (gaussian mu sig) 
>                                 [0.0, 0.001 .. 1.0])
>	     max  = last vals
>        in listArray (0,1000) (map (/max) vals)

Then we define a function that searches for the right index:

> gCDF :: Double -> Double
> gCDF x = f 0 where
>   f 1000 = 1.0
>   f i    = if gcdf!i > x then (fromIntegral i)/1000
>	     else f (i+1)

Finally, we have:

> gaussNums :: [Double]
> gaussNums = map gCDF randNums

Cemetary:

 normGauss :: Double -> Double -> Double -> Double
 normGauss mu sig x = 
    let f y = exp ((-(y-mu)**2)/(2*sig**2)) / (sig * sqrt (2*pi))
        min = f 0; max = f 0.5
    in (f x - min) / (max - min)

Problem 3
---------

Define Haskell functions "invert", "retro", "retroInvert", and
"invertRetro" to implement the concepts of inversion, retrograde,
retrograde inversion, and inverted retrograde, respectively, as used
in twelve-tone music theory.  You may assume that the input to these
functions is created by an application of the "line" function in
Haskore.  Prove that "retro . retro", "invert . invert", and
"retroInvert . invertRetro" are the identity function on values
created by "line".

Here are the solutions from Transition/Basics:

 lineToList :: Music -> [Music]
 lineToList n@(Rest 0) = []
 lineToList (n :+: ns) = n : lineToList ns

 retro, invert, retroInvert, invertRetro :: Music -> Music
 retro    = line . reverse . lineToList
 invert m = line (map inv l)
   where l@(Note r _ _: _)  = lineToList m
         inv (Note p d nas) = Note (pitch (2*(absPitch r) - absPitch p)) d nas
         inv (Rest d)       = Rest d
 retroInvert = retro  . invert
 invertRetro = invert . retro

And here are solutions I wrote before remembering that the above
existed!!

First, a function to "recover" the list from an application of line:

> unLine :: Music -> [Music]
> unLine = foldM ((:[]).mkNote) (error "not a line") (++)

> mkNote (p,d) = Note p d []

(This assume that there are no rests.)

Then retrograde is easy:

> retro' :: Music -> Music
> retro' = line . reverse . unLine

Inversion is sometimes done with respect to the first note, but I will
make it more general by doing it with respect to a given pitch:

> invert' :: Pitch -> Music -> Music
> invert' p = line . map f . unLine
>   where f (Note p' d []) = let absp  = absPitch p
>                                absp' = absPitch p'
>                            in Note (pitch (2*absp - absp')) d []

retroInvert and invertRetro are just compositions:

> retroInvert', invertRetro' :: Pitch -> Music -> Music
> retroInvert' p = retro' . invert' p
> invertRetro' p = invert' p . retro'

Here is a sketch of one of the proofs:

Lemma 1: unLine  . line    = id
Lemma 2: reverse . reverse = id
Lemma 3: (f . g) . h = f . (g . h)

retro . retro
=> (line . reverse . unLine) . (line . reverse . unLine)
=> line . reverse . unLine . line . reverse . unLine
=> line . reverse . reverse . unLine
=> line . unLine
=> id