module Types where
import Control.Parallel.Strategies (parMap, rpar)
import Control.Concurrent.Async (forConcurrently, mapConcurrently)
import Data.List (intersperse, maximumBy, sort, sortBy)
import qualified Data.Map as M
import qualified Data.Set as S
-- | Time in crochet beats.
type Time = Double
-- | MIDI values are represented with integers.
type MIDI = Integer
-- | Intervals are represented with integers (i.e. number of semitones).
type Interval = Integer
type ScaleDegree = Int
type Length = Int
-- | A pattern group is one of the patterns of a piece of music, identified by an expert
-- or algorithm, and defined by a pattern prototype and other pattern occurences.
data PatternGroup = PatternGroup
{ piece_name :: String
-- ^ the name of the music piece, that the pattern group belongs to
, expert_name :: String
-- ^ music expert or algorithm that produced the pattern occurences
, pattern_name :: String
-- ^ the name of the current pattern group
, basePattern :: Pattern
-- ^ the pattern prototype (always taken from `occ1.csv`)
, patterns :: [Pattern]
-- ^ all other pattern occurences of the prototype
} deriving (Eq)
instance Show PatternGroup where
-- | Get a title, unique to the given PatternGroup, in the following format:
-- <piece>:<expert>:<pattern>.
show (PatternGroup piece_n expert_n pattern_n _ _) =
concat $ intersperse ":" [piece_n, expert_n, pattern_n]
-- | A pattern is a sequence of notes.
type Pattern = [Note]
-- | A simplistic music note (only time and pitch).
data Note = Note { ontime :: Time -- ^ onset time
, midi :: MIDI -- ^ MIDI number
} deriving (Eq, Show)
-- | Infix variant of the Note constructor.
(.@) :: MIDI -> Time -> Note
(.@) = flip Note
(.@@) :: [Time] -> [MIDI] -> [Note]
(.@@) = zipWith Note
-- | A piece of music is a huge pattern.
type MusicPiece = Pattern
-- | Songs are identified with a string.
type Song = String
-----------------------
-- Utilities
-- | Negate the values of a numeric list.
inverse :: Num a => [a] -> [a]
inverse = fmap negate
-- | The base pitch of a pattern (the pitch of its first note).
-- e.g. basePitch [(25,1), (27,2), (25,2.5)] = Just 25
basePitch :: Pattern -> Maybe MIDI
basePitch (Note _ m:_) = Just m
basePitch [] = Nothing
-- | The (real) pitch structure of a pattern.
-- e.g. pitch [(25,1), (27,2), (25,2.5)] = [25, 27, 25]
pitch :: Pattern -> [MIDI]
pitch = fmap midi
-- | The (relative) pitch structure of a pattern.
-- e.g. intervals [(25,1), (27,2), (25,2.5)] = [2, -2]
intervals :: Pattern -> [Interval]
intervals = fmap (uncurry (-)) . pairs . pitch
-- | The (real) rhythmic structure of a pattern.
-- e.g. onset [(25,1), (27,2), (25,2.5)] = [1, 2, 2.5]
onsets :: Pattern -> [Time]
onsets = sort . fmap ontime
-- | The (relative) rhythmic structure of a pattern.
-- e.g. rhythm [(25,1), (27,2), (25,2.5)] = [1, 0.5]
durations :: Pattern -> [Time]
durations = fmap (uncurry (-)) . pairs . onsets
rhythm :: Pattern -> [Time]
rhythm = map (truncate' 2) . durations
-- | Normalized (relative) rhythmic structure of a pattern.
-- e.g. normalRhythm [(A,2), (C#,6), (Eb,8), (B,1), (A,2)] = [1, 3, 4, 1/2, 1]
normalRhythm :: Pattern -> [Time]
normalRhythm = normalizeTime . rhythm
where
-- | Convert times to ratios wrt the first time unit used.
-- e.g. normalizeTime [2, 6, 8, 6, 1, 2] = [1, 3, 4, 1/2, 1]
normalizeTime :: [Time] -> [Time]
normalizeTime (tt : ts) = 1 : ((/ tt) <$> ts)
normalizeTime [] = []
-- | Translate a note horizontally (in time).
-- e.g. translateH (-0.5) [(25,1), (27,2), (25,2.5)] = [(25,0.5), (27,1.5), (25,2)]
translateH :: Time -> Note -> Note
translateH dt (Note tInit m) = Note (tInit + dt) m
-- | Translate a note vertically (in pitch).
-- e.g. translateV (-20) [(25,1), (27,2), (25,2.5)] = [(5,1), (7,2), (5,2.5)]
translateV :: Interval -> Note -> Note
translateV dm (Note tt mInit) = Note tt (mInit + dm)
-- | Get list as pairs of consecutive elements.
-- e.g. pairs [a, b, c, d] = [(a, b), (b, c), (c, d)]
pairs :: [a] -> [(a, a)]
pairs xs = zip (tail xs) xs
truncate' :: Int -> Double -> Double
truncate' n x = fromIntegral (floor (x * t)) / t
where t = 10^n
-----------------------
-- Scales/modes
type Octave = Integer
type Degree = Integer
type ScaleType = [Interval]
type Scale = M.Map MIDI (Degree, Octave)
major, harmonicMinor, melodicMinor :: ScaleType
major = [0,2,4,5,7,9,11]
melodicMinor = [0,2,3,5,7,9,11]
harmonicMinor = [0,2,3,5,7,8,11]
createScaleInC :: ScaleType -> Scale
createScaleInC scType = M.fromList [ (24 + (oct * 12) + m, (i, oct + 1))
| oct <- [0..7]
, (i, m) <- zip [1..7] scType ]
createScaleInD :: ScaleType -> Scale
createScaleInD scType = M.fromList [ (26 + (oct * 12) + m, (i, oct + 1))
| oct <- [0..7]
, (i, m) <- zip [1..7] scType ]
allScales :: [Scale]
allScales = [ M.mapKeys (+ transp) (createScaleInC scType)
| scType <- [major, harmonicMinor, melodicMinor]
, transp <- [0..11] ]
guessScale :: Pattern -> Scale
guessScale xs =
let scales = [ (sc, S.size $ M.keysSet sc `S.intersection` S.fromList (pitch xs))
| sc <- allScales ]
in fst $ maximumBy (\(_,s1) (_,s2) -> if s1 > s2 then GT
else if s1 < s2 then LT
else EQ) scales
guessScaleCandidates :: Int -> Pattern -> [Scale]
guessScaleCandidates n xs =
let scales = [ (sc, S.size $ M.keysSet sc `S.intersection` S.fromList (pitch xs))
| sc <- allScales ]
in take n $ map fst (sortBy (\(_,s1) (_,s2) -> if s1 > s2 then GT
else if s1 < s2 then LT
else EQ) scales)
toDegree :: Scale -> MIDI -> Integer
toDegree sc m = i + (oct * 7)
where (i, oct) = M.findWithDefault (0, 0) m sc -- 0 for 'outside' note
applyScale :: Scale -> Pattern -> [Interval]
applyScale sc = fmap (uncurry (-)) . pairs . fmap (toDegree sc) . pitch
-----------------------
-- Parallel operations
-- | Parallel map.
pmap :: (a -> b) -> [a] -> [b]
pmap = parMap rpar
-- | Parallel forM.
pforM :: Traversable t => t a -> (a -> IO b) -> IO (t b)
pforM = forConcurrently
-- | Parallel mapM.
pmapM :: Traversable t => (a -> IO b) -> t a -> IO (t b)
pmapM = mapConcurrently