module Sound.Analysis.SHARC where
import Text.XML.Light
data Instrument = Instrument {instrument_id :: String
,notes :: [Note]}
data Note = Note {frequency :: Double
,partials :: [Partial]}
data Partial = Partial {partial :: Int
,amplitude :: Double
,phase :: Double}
read_sharc :: FilePath -> IO (Either String [Instrument])
read_sharc fn = do
s <- readFile fn
return (case parseXMLDoc s of
Just e -> Right (parse_tree e)
Nothing -> Left "parse failed")
partial_frequency :: Double -> Partial -> Double
partial_frequency f = (* f) . fromIntegral . partial
partial_triple :: Double -> Partial -> (Double,Double,Double)
partial_triple f p = (partial_frequency f p,amplitude p,phase p)
note_spectra :: Note -> [(Double,Double,Double)]
note_spectra n =
let f = frequency n
p = partials n
f' = map ((* f) . fromIntegral . partial) p
in zip3 f' (map amplitude p) (map phase p)
note_n_partials :: Note -> Int
note_n_partials = length . partials
partial_scale_amplitude :: Double -> Partial -> Partial
partial_scale_amplitude x (Partial i a p) = Partial i (x * a) p
note_scale_amplitude :: Double -> Note -> Note
note_scale_amplitude x (Note f p) =
let p' = map (partial_scale_amplitude x) p
in Note f p'
note_amplitude_minmax :: Note -> (Double,Double)
note_amplitude_minmax n =
let a = map amplitude (partials n)
in (minimum a,maximum a)
note_normalise :: Note -> Note
note_normalise n =
let (_,u) = note_amplitude_minmax n
in note_scale_amplitude (recip u) n
instrument_amplitude_minmax :: Instrument -> (Double,Double)
instrument_amplitude_minmax i =
let (l,r) = unzip (map note_amplitude_minmax (notes i))
in (minimum l,maximum r)
instrument_normalise :: Instrument -> Instrument
instrument_normalise i =
let (_,u) = instrument_amplitude_minmax i
n = notes i
in i {notes = map (note_scale_amplitude (recip u)) n}
parse_tree :: Element -> [Instrument]
parse_tree = map parse_instrument . findChildren (unqual "instrument")
parse_instrument :: Element -> Instrument
parse_instrument e =
let Just i = findAttr (unqual "id") e
n = findChildren (unqual "note") e
in Instrument i (map parse_note n)
parse_note :: Element -> Note
parse_note e =
let Just f = findAttr (unqual "fundHz") e
p = findChildren (unqual "a") e
in Note (read f) (map parse_partial p)
parse_partial :: Element -> Partial
parse_partial e =
let a = strContent e
Just n = findAttr (unqual "n") e
Just p = findAttr (unqual "p") e
in Partial (read n) (read a) (read p)