SHARC.hs

-- | SHARC XML file IO.
module Sound.Analysis.SHARC where

import Text.XML.Light {- xml -}

-- | A SHARC instrument.
data Instrument = Instrument {instrument_id :: String
                             ,notes :: [Note]}

-- | A SHARC note.
data Note = Note {frequency :: Double
                 ,partials :: [Partial]}

-- | A SHARC partial.
data Partial = Partial {partial :: Int
                       ,amplitude :: Double
                       ,phase :: Double}

-- | Read a SHARC XML file.
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 analysis

-- | Calculate the frequency of a 'Partial' given the fundamental frequency.
--
-- > partial_frequency 440 (Partial 3 0.1 0) == 1320
partial_frequency :: Double -> Partial -> Double
partial_frequency f = (* f) . fromIntegral . partial

-- | Calculate the @(frequency,amplitude,phase)@ triple of a
-- 'Partial' given the fundamental frequency.
--
-- > partial_triple 440 (Partial 3 0.1 pi) == (1320,0.1,pi)
partial_triple :: Double -> Partial -> (Double,Double,Double)
partial_triple f p = (partial_frequency f p,amplitude p,phase p)

-- * Note analysis

-- | Translate a 'Note' into (/frequency/,/amplitude/,/phase/) triples.
--
-- > note_spectra (Note 440 [Partial 3 0.1 pi]) == [(1320,0.1,pi)]
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)

-- | The number of partials at a 'Note'.
note_n_partials :: Note -> Int
note_n_partials = length . partials

-- * Amplitude transformations

-- | Apply a linear scalar to the amplitude of a 'Partial'.
partial_scale_amplitude :: Double -> Partial -> Partial
partial_scale_amplitude x (Partial i a p) = Partial i (x * a) p

-- | Apply a linear scalar to the amplitudes of all 'Partial's at a 'Note'.
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'

-- | Find the minimum and maximum amplitudes of all 'Partial's at a
-- 'Note'.
note_amplitude_minmax :: Note -> (Double,Double)
note_amplitude_minmax n =
    let a = map amplitude (partials n)
    in (minimum a,maximum a)

-- | Normalise a 'Note' so the maximum amplitude of any 'Partial' is
-- @1.0@.
note_normalise :: Note -> Note
note_normalise n =
    let (_,u) = note_amplitude_minmax n
    in note_scale_amplitude (recip u) n

-- | Find the minimum and maximum amplitudes of all 'Partial's at all
-- 'Note's of an 'Instrument'.
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)

-- | Normalise an 'Instrument' so the maximum amplitude of any
-- 'Partial' is @1.0@.
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}

-- * XML parsers

-- | The root 'Element' of a SHARC xml graphs is a @tree@, which
-- parses to a list of 'Instrument's.
parse_tree :: Element -> [Instrument]
parse_tree = map parse_instrument . findChildren (unqual "instrument")

-- | Parse an @instrument@ 'Element'.
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 a @note@ 'Element'.
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 an @a@ 'Element'.
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)