{-# LANGUAGE PostfixOperators #-}
module Grammar.Utilities where
import Control.Arrow (first)
import Music
import System.Random
(<|>) :: a -> a -> IO a
x <|> y = oneOf [x, y]
(<||>) :: IO a -> IO a -> IO a
x' <||> y' = do
x <- x'
y <- y'
x <|> y
oneOf :: [a] -> IO a
oneOf = choose . fmap (\a -> (1, a))
chooseWith :: (a -> Double) -> [a] -> IO a
chooseWith f = choose . fmap (\a -> (f a, a))
choose :: [(Double, a)] -> IO a
choose items = do
let totalWeight = sum $ fst <$> items
index <- getStdRandom $ randomR (0, totalWeight)
return $ pick index items
pick :: Double -> [(Double, a)] -> a
pick n ((w, a):es) =
if n <= w || null es
then a
else pick (n-w) es
pick _ _ = error "pick: empty list"
equally :: [a] -> [(Double, a)]
equally = zip (repeat 1.0)
normally :: [(Double, a)] -> [(Double, a)]
normally xs = first (/ sum (map fst xs)) <$> xs
type ListMusic a = [(a, Duration)]
toList :: Music a -> ListMusic a
toList (m :+: m') = toList m ++ toList m'
toList(Note d a) = [(a, d)]
toList (_ :=: _) = error "toList: non-sequential music"
toList (Rest _) = error "toList: rest exists"
fromList :: ListMusic a -> Music a
fromList = line . fmap (uncurry (<|))
type ListMusicM a = [(Maybe a, Duration)]
toListM :: Music a -> ListMusicM a
toListM (m :+: m') = toListM m ++ toListM m'
toListM (_ :=: _) = error "toListM: non-sequential music"
toListM (Note d a) = [(Just a, d)]
toListM (Rest d) = [(Nothing, d)]
fromListM :: ListMusicM a -> Music a
fromListM = line . fmap f
where f (Just a, t) = a <| t
f (Nothing, t) = (t~~)
chordDistance :: Chord -> Chord -> Int
chordDistance c c' = sum $ uncurry pitchDistance <$> zip c c'
pitchDistance :: Pitch -> Pitch -> Int
pitchDistance p p' = abs $ fromEnum p - fromEnum p'
pitchDistanceM :: Maybe Pitch -> Pitch -> Int
pitchDistanceM Nothing = const 1
pitchDistanceM (Just p) = pitchDistance p
distancePc :: PitchClass -> PitchClass -> Interval
distancePc pc pc' = toEnum $ abs $ fromEnum pc - fromEnum pc'