classify-frog-0.2.3: src/Durations.hs

{-# LANGUAGE RebindableSyntax #-}
module Durations where

import qualified ClassRecord
import qualified Class

import qualified Sound.Audacity.LabelTrack as LabelTrack

import Control.DeepSeq (NFData, rnf, force)
import Control.Applicative (Applicative, liftA2, pure, (<*>))

import qualified Data.Traversable as Trav
import qualified Data.Foldable as Fold
import Data.Traversable (Traversable, traverse)
import Data.Foldable (Foldable, foldMap)

import qualified Algebra.Additive as Additive
import NumericPrelude.Numeric hiding (sum)
import NumericPrelude.Base hiding (readFile, writeFile)


data T a =
   Cons {
      total :: a,
      classes :: ClassRecord.T a
   }

names :: T String
names = Cons "Total" ClassRecord.names

instance NFData a => NFData (T a) where
   rnf (Cons totalDur classDurs) = rnf (totalDur, classDurs)

instance Functor T where
   fmap = Trav.fmapDefault

instance Foldable T where
   foldMap = Trav.foldMapDefault

instance Traversable T where
   traverse f (Cons totalDur classDurs) =
      liftA2 Cons (f totalDur) (traverse f classDurs)

instance Applicative T where
   pure a = Cons a $ pure a
   Cons fTotal fClasses <*> Cons totalDur classDurs =
      Cons (fTotal totalDur) (fClasses <*> classDurs)


class Track f where
   intervalSizes :: (Additive.C t) => f t a -> f t (t, a)

-- ToDo: move to audacity
instance Track LabelTrack.T where
   intervalSizes =
      LabelTrack.mapWithTime (\bnds lab -> (uncurry subtract bnds, lab))


sum ::
   (Track f, Foldable (f Double)) =>
   f Double (Class.Abstract advert rasping chirping ticking growling) ->
   T Double
sum =
   Fold.foldl'
      (\(Cons totalDur acc) (dur,cls) ->
         let add r select set = set r $ select r + dur
         in  force $ Cons (totalDur+dur) $
             case cls of
                Class.Advertisement _ _ _ ->
                   add acc ClassRecord.advertisement
                      (\r d -> r{ClassRecord.advertisement = d})
                Class.NoAdvertisement (Class.Rasping _) ->
                   add acc ClassRecord.rasping
                      (\r d -> r{ClassRecord.rasping = d})
                Class.NoAdvertisement (Class.Chirping _) ->
                   add acc ClassRecord.chirping
                      (\r d -> r{ClassRecord.chirping = d})
                Class.NoAdvertisement (Class.Ticking _) ->
                   add acc ClassRecord.ticking
                      (\r d -> r{ClassRecord.ticking = d})
                Class.NoAdvertisement (Class.Growling _) ->
                   add acc ClassRecord.growling
                      (\r d -> r{ClassRecord.growling = d})
                Class.NoAdvertisement (Class.Other _) -> acc)
      (pure 0) .
   intervalSizes