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
type Time = Double
type MIDI = Integer
type Interval = Integer
type ScaleDegree = Int
type Length = Int
data PatternGroup = PatternGroup
{ piece_name :: String
, expert_name :: String
, pattern_name :: String
, basePattern :: Pattern
, patterns :: [Pattern]
} deriving (Eq)
instance Show PatternGroup where
show (PatternGroup piece_n expert_n pattern_n _ _) =
concat $ intersperse ":" [piece_n, expert_n, pattern_n]
type Pattern = [Note]
data Note = Note { ontime :: Time
, midi :: MIDI
} deriving (Eq, Show)
(.@) :: MIDI -> Time -> Note
(.@) = flip Note
(.@@) :: [Time] -> [MIDI] -> [Note]
(.@@) = zipWith Note
type MusicPiece = Pattern
type Song = String
inverse :: Num a => [a] -> [a]
inverse = fmap negate
basePitch :: Pattern -> Maybe MIDI
basePitch (Note _ m:_) = Just m
basePitch [] = Nothing
pitch :: Pattern -> [MIDI]
pitch = fmap midi
intervals :: Pattern -> [Interval]
intervals = fmap (uncurry (-)) . pairs . pitch
onsets :: Pattern -> [Time]
onsets = sort . fmap ontime
durations :: Pattern -> [Time]
durations = fmap (uncurry (-)) . pairs . onsets
rhythm :: Pattern -> [Time]
rhythm = map (truncate' 2) . durations
normalRhythm :: Pattern -> [Time]
normalRhythm = normalizeTime . rhythm
where
normalizeTime :: [Time] -> [Time]
normalizeTime (tt : ts) = 1 : ((/ tt) <$> ts)
normalizeTime [] = []
translateH :: Time -> Note -> Note
translateH dt (Note tInit m) = Note (tInit + dt) m
translateV :: Interval -> Note -> Note
translateV dm (Note tt mInit) = Note tt (mInit + dm)
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
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
applyScale :: Scale -> Pattern -> [Interval]
applyScale sc = fmap (uncurry (-)) . pairs . fmap (toDegree sc) . pitch
pmap :: (a -> b) -> [a] -> [b]
pmap = parMap rpar
pforM :: Traversable t => t a -> (a -> IO b) -> IO (t b)
pforM = forConcurrently
pmapM :: Traversable t => (a -> IO b) -> t a -> IO (t b)
pmapM = mapConcurrently