Ticket #3632: tmp.hs

{-# LANGUAGE RankNTypes, ExistentialQuantification, RecordWildCards, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts #-}

module Main () where

import Control.Arrow
import Control.Applicative
import System.Random
import Control.Monad.State
import Control.Monad.Identity
import Data.Maybe
import Data.List

-- *params

tempo     = 200 -- bpm
timeSig   = TimeSig { numBeats = 4
                    , unit     = Quarter
                    }

intervals = [2,1,2,2,1,2,2]; -- minor scale

numMeasures = 8
noteRange = (-20,20)

-- *main algorithm

composeMeasure :: (MonadSupply Int m, Integral a) => a -> m [Note]
composeMeasure mn =
    mapM replaceNoteNum notes
    where measureNum = fromIntegral mn 
          notes = if measureNum == numMeasures
                     then [downbeat]
                     else [badjust n b | n <- [downbeat, adjust downbeat 100 (2/3) (Triplet Eighth)]
                                       , b <- [0 .. numBeats timeSig - 1]
                                       ] 
                                       -- need dev snapshot of ghc (6.12) to update existential records (compare http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#existential-records
                                                                                                    -- vs. http://www.haskell.org/ghc/dist/current/docs/html/users_guide/data-type-extensions.html#existential-records)
{-                                    [n {beat = b} | n <- [downbeat, downbeat {vel = 100, subdiv = 2/3, dur = Triplet Eighth}]
                                                    , b <- [0 .. numBeats timeSig - 1]
                                                    ] -}
          downbeat = Note { midiNum = 60
                          , vel     = 75
                          , chan    = 0
                          , measure = fromIntegral measureNum
                          , beat    = 0
                          , subdiv  = 0
                          , dur     = Triplet Quarter
                          }
          replaceNoteNum x = do
            (Just o) <- untilM ((/= 0) . fromJust) (const $ (fmap signum) <$> snext) $ Just 0
            (Just m) <- snext
            let nr :: (Real r) => (Note -> r) -> (Note -> Rational)
                nr = (toRational .)
                interval = getInterval (if measureNum == numMeasures 
                                           then 0 
                                           else m + if odd (mod m $ length intervals) && (and . map (== 0) $ [nr beat, nr subdiv] <*> [x]) -- see discussion of why not to use existentials here http://tunes.org/~nef//logs/haskell/09.08.12
                                                       then o -- on first beat of each measure play a chord tone
                                                       else 0
                                       ) intervals
            return $ move x interval {- x {midiNum = midiNum x + interval} -} -- see above re: updating existential records

-- *support to eliminate

move :: Note -> Int -> Note
move Note{..} i = Note {
      midiNum = midiNum + i
    , vel     = vel
    , chan    = chan
    , measure = measure
    , beat    = beat
    , subdiv  = subdiv
    , dur     = dur
    }

adjust :: (RealFrac a, NoteDur b) => Note -> Int -> a -> b -> Note
adjust Note{..} v s d = Note {
      midiNum = midiNum
    , vel     = v
    , chan    = chan
    , measure = measure
    , beat    = beat
    , subdiv  = realToFrac s
    , dur     = d
    }

badjust :: Note -> Int -> Note
badjust Note{..} b = Note {
      midiNum = midiNum
    , vel     = vel
    , chan    = chan
    , measure = measure
    , beat    = b
    , subdiv  = subdiv
    , dur     = dur
    }

-- *midi/music util

data DurBase = Whole | Half | Quarter | Eighth | Sixteenth | ThirtySecond deriving (Enum, Bounded, Show, Eq)
data ModDur = forall x. NoteDur x => Dotted x | Triplet DurBase

data TimeSig = TimeSig {
      numBeats :: Int
    , unit     :: DurBase
    }

data Note = forall x . NoteDur x => Note {
      midiNum :: Int -- 0-255
    , vel     :: Int -- 0-255
    , chan    :: Int -- 0-15
    , measure :: Integral a => a
    , beat    :: Int
    , subdiv  :: RealFrac a => a -- % of beat
    , dur     :: x
    }

class NoteDur a where
    quarters :: (Real x, Floating x) => a -> x 
     
    calcDurMS :: (Real x, Floating x) => a -> x
    calcDurMS d = 1000 * 60 * (beats d) / (realToFrac tempo)

    beats :: (Real x, Floating x) => a -> x   
--  beats d = (quarters d) / (quarters $ unit timeSig) -- want to factor out the application of quarters
--  beats d = uncurry (/) $ join (***) quarters (d, unit timeSig) -- join (***) from Saizan_ @ #haskell, but isn't existentially polymorphic
    beats d = uncurry (/) $ both quarters (d, unit timeSig)
        where both (f :: forall a b. (NoteDur a, Real b, Floating b) => a -> b) (x, y) = (f x, f y) -- lame that this has to be class specific (copumpkin @ #haskell says a 'forall classes' would be nice)

instance NoteDur DurBase where
    quarters x = z where Just z = lookup x $ zip [minBound .. maxBound] $ map (2 **) $ map realToFrac [2, 1 ..]

instance NoteDur ModDur where
{- why isn't something like this OK?  scree @ #haskell points out that if NoteDur were a type instead of a class it would work, but then we have to carry around another constructor (ie: NoteDur Dotted Eighth)
    quarters (x y) = quarters y * case x of
        Dotted  -> 3 / 2
        Triplet -> 2 / 3
-}
    quarters (Dotted  x) = quarters x * 3 / 2
    quarters (Triplet x) = quarters x * 2 / 3

instance NoteDur Note where
     quarters Note{..} = quarters dur

calcStartMS :: RealFrac a => Note -> a
calcStartMS n = realToFrac $ ((subdiv n) + (fromIntegral ((measure n) * (numBeats timeSig) + (beat n)))) * (calcDurMS $ unit timeSig)

getInterval :: Int -> [Int] -> Int
getInterval n is 
        | n >= 0    = d * (last s) + if m == 0 
                                        then 0 
                                        else s !! (m-1)
        | otherwise = getInterval (-n) . map (* (-1)) $ reverse is -- could avoid this reverse with some fold fu
    where (d,m) = divMod n $ length is
          s     = cumsum is

-- *algorithm support

type SupT = SupplyT Int

compose :: IO ()
compose = do
    join . runRandomRIOT noteRange $ mapM_ makeNotes [0 .. numMeasures]
    putStrLn "done making notes"

makeNotes :: (Integral a) => a -> (SupT IO) ()
makeNotes thisMeasureNum = do
    liftIO . putStrLn $ "composing measure " ++ show thisMeasureNum
    liftIO . mapM_ rptNote =<< composeMeasure thisMeasureNum

rptNote :: Note -> IO ()
rptNote n = do
    let startT     = round $ calcStartMS n
        endT       = startT + (round $ calcDurMS n)
    putStrLn $ "\t" ++ show startT ++ " - " ++ show endT ++ ": " ++ (show $ midiNum n)

-- *util: random supply

-- adapted from http://www.haskell.org/haskellwiki/New_monads/MonadSupply
-- hides implementation, handles finite supplies, includes function to get multiple items
-- much taken from RWH's Supply monad in ch. 15: http://book.realworldhaskell.org/read/programming-with-monads.html#id646649
-- transformer in ch. 18: http://book.realworldhaskell.org/read/monad-transformers.html#monadtrans.maybet

newtype SupplyT s m a = ST (StateT [s] m a) deriving (Functor, Monad, MonadTrans, MonadIO)
newtype Supply s a = S (SupplyT s Identity a) deriving (Monad, Functor, MonadSupply s)

class (Monad m, Functor m) => MonadSupply s m | m -> s where
    snext  :: m (Maybe s)
    snext  =  head <$> snexts 1
    snexts :: Integral a => a -> m [Maybe s]

instance (Monad m, Functor m) => MonadSupply s (SupplyT s m) where
    snexts n = ST $ do -- blackh @ #haskell's solution, cleaner than my Kleislis
        (these,rest) <- genericSplitAt n <$> get
        put rest
        return . genericTake n $ map Just these ++ repeat Nothing

runSupply :: Supply s a -> [s] -> (a, [s])
runSupply (S m) = runIdentity . runSupplyT m

runSupplyT :: Functor m => SupplyT s m a -> [s] -> m (a, [s])
runSupplyT (ST s) = runStateT s

evalSupply :: Supply s a -> [s] -> a
evalSupply (S s) = runIdentity . evalSupplyT s

evalSupplyT :: (Functor m) => SupplyT s m a -> [s] -> m a
evalSupplyT = fmap fst `dot` runSupplyT

randomsRIO :: Random a => (a,a) -> IO [a] -- note System.Random is known to be very slow, but this application isn't very demanding (see discussion here, incl pointers to nonuniform distributions: http://www.serpentine.com/blog/2009/09/19/a-new-pseudo-random-number-generator-for-haskell/)
randomsRIO lims = getStdRandom $ first (randomRs lims) . split

runRandomRIO :: (Random s) => (s, s) -> Supply s a -> IO a
runRandomRIO r s = fmap (evalSupply s) $ randomsRIO r

runRandomRIOT :: (Functor m, Random s) => (s, s) -> SupplyT s m a -> IO (m a)
runRandomRIOT r s = fmap (evalSupplyT s) $ randomsRIO r

-- *other util

cumsum :: Num a => [a] -> [a]
cumsum = scanl1 (+)

-- from http://www.haskell.org/haskellwiki/Pointfree#Dot
-- note (f `dot` g) x = f . g x (http://stackoverflow.com/questions/907306/confusion-about-currying-and-point-free-style-in-haskell)
dot :: (c -> d) -> (a -> b -> c) -> a -> b -> d
dot = (.) . (.)

-- from http://www.haskell.org/pipermail/beginners/2009-January/000690.html (via byorgey @ #haskell)
untilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a
untilM p f x | p x       = return x
             | otherwise = f x >>= untilM p f

-- *main

main :: IO ()
main = compose