classify-frog-0.2.3: src/Class.hs

module Class where

import qualified Label

import Control.DeepSeq (NFData, rnf)
import Control.Monad (mplus, mfilter)

import qualified Data.Foldable as Fold
import qualified Data.List.HT as ListHT
import qualified Data.Map as Map; import Data.Map (Map)
import Data.String.HT (trim)
import Data.Maybe (fromMaybe)
import Data.Maybe.HT (toMaybe)
import Data.Char (isDigit)


data Sound rasping chirping ticking growling =
     Other String
   | Rasping rasping
   | Chirping chirping
   | Ticking ticking
   | Growling growling

instance
   (NFData rasping, NFData chirping, NFData ticking, NFData growling) =>
      NFData (Sound rasping chirping ticking growling) where
   rnf (Other str) = rnf str
   rnf (Rasping dat) = rnf dat
   rnf (Chirping dat) = rnf dat
   rnf (Ticking dat) = rnf dat
   rnf (Growling dat) = rnf dat


isPause :: Sound rasping chirping ticking growling -> Bool
isPause (Other str) = str == Label.pause
isPause _ = False


toName :: Sound rasping chirping ticking growling -> String
toName cl =
   case cl of
      Other str -> str
      Rasping _ -> Label.rasping
      Chirping _ -> Label.chirping
      Ticking _ -> Label.ticking
      Growling _ -> Label.growling

toLabel :: Sound Int chirping Int Int -> String
toLabel cl =
   case cl of
      Other str -> str
      Rasping numClicks -> Label.rasping ++ ' ' : show numClicks
      Chirping _ -> Label.chirping
      Ticking numClicks -> Label.ticking ++ ' ' : show numClicks
      Growling numClicks -> Label.growling ++ ' ' : show numClicks


type SoundParsed = Sound String String String String

fromLabel :: String -> SoundParsed
fromLabel lab =
   fromMaybe (Other lab) $
   fmap (Rasping . trim) (ListHT.maybePrefixOf Label.rasping lab)
   `mplus`
   fmap (Chirping . trim) (ListHT.maybePrefixOf Label.chirping lab)
   `mplus`
   fmap (Ticking . trim) (ListHT.maybePrefixOf Label.ticking lab)
   `mplus`
   fmap (Growling . trim) (ListHT.maybePrefixOf Label.growling lab)

strToLabel :: SoundParsed -> String
strToLabel cl =
   let add ext str = if null ext then str else str ++ ' ' : ext
   in case cl of
         Other str -> str
         Rasping str -> add Label.rasping str
         Chirping str -> add Label.chirping str
         Ticking str -> add Label.ticking str
         Growling str -> add Label.growling str


data Purity = Pure | Rumble
   deriving (Eq)

type SoundPurity = Sound Purity Purity Purity Purity

purityToName :: SoundPurity -> String
purityToName cl =
   let ext p =
         case p of
            Pure -> ""
            Rumble -> " rumble"
   in case cl of
         Other str -> str
         Rasping p -> Label.rasping ++ ext p
         Chirping p -> Label.chirping ++ ext p
         Ticking p -> Label.ticking ++ ext p
         Growling p -> Label.growling ++ ext p

checkPurity :: SoundParsed -> SoundPurity
checkPurity cl =
   fromMaybe (Other $ strToLabel cl) $
   let check cons p str =
         toMaybe (str==Label.rumble) (cons Rumble)
         `mplus`
         toMaybe (p str) (cons Pure)
   in case cl of
         Other str -> Just $ Other str
         Rasping str -> check Rasping (all isDigit) str
         Chirping str -> check Chirping null str
         Ticking str -> check Ticking (all isDigit) str
         Growling str -> check Growling (all isDigit) str

setRumble :: Bool -> SoundPurity -> SoundPurity
setRumble b cl =
   let add r = if b then Rumble else r
   in  case cl of
         Other str ->
            Other $
            if b
              then
                if str == Label.pause
                  then Label.rumble
                  else str ++ ' ' : Label.rumble
              else str
         Rasping r -> Rasping $ add r
         Chirping r -> Chirping $ add r
         Ticking r -> Ticking $ add r
         Growling r -> Growling $ add r


mapChirping ::
   (chirping0 -> chirping1) ->
   Sound rasping chirping0 ticking growling ->
   Sound rasping chirping1 ticking growling
mapChirping f cl =
   case cl of
      Other str -> Other str
      Rasping r -> Rasping r
      Chirping ch -> Chirping $ f ch
      Ticking t -> Ticking t
      Growling g -> Growling g

mapRasping ::
   (rasping0 -> rasping1) ->
   Sound rasping0 chirping ticking growling ->
   Sound rasping1 chirping ticking growling
mapRasping f cl =
   case cl of
      Other str -> Other str
      Rasping r -> Rasping $ f r
      Chirping ch -> Chirping ch
      Ticking t -> Ticking t
      Growling g -> Growling g

mapTicking ::
   (ticking0 -> ticking1) ->
   Sound rasping chirping ticking0 growling ->
   Sound rasping chirping ticking1 growling
mapTicking f cl =
   case cl of
      Other str -> Other str
      Rasping r -> Rasping r
      Chirping ch -> Chirping ch
      Ticking t -> Ticking $ f t
      Growling g -> Growling g

mapGrowling ::
   (growling0 -> growling1) ->
   Sound rasping chirping ticking growling0 ->
   Sound rasping chirping ticking growling1
mapGrowling f cl =
   case cl of
      Other str -> Other str
      Rasping r -> Rasping r
      Chirping ch -> Chirping ch
      Ticking t -> Ticking t
      Growling g -> Growling $ f g


maybeRasping :: Sound rasping chirping ticking growling -> Maybe rasping
maybeRasping cl =
   case cl of
      Rasping r -> Just r
      _ -> Nothing

maybeChirping :: Sound rasping chirping ticking growling -> Maybe chirping
maybeChirping cl =
   case cl of
      Chirping c -> Just c
      _ -> Nothing

maybeTicking :: Sound rasping chirping ticking growling -> Maybe ticking
maybeTicking cl =
   case cl of
      Ticking r -> Just r
      _ -> Nothing

maybeGrowling :: Sound rasping chirping ticking growling -> Maybe growling
maybeGrowling cl =
   case cl of
      Growling r -> Just r
      _ -> Nothing

maybeOther :: Sound rasping chirping ticking growling -> Maybe String
maybeOther cl =
   case cl of
      Other s -> Just s
      _ -> Nothing


countOthers ::
   (Fold.Foldable f) =>
   f (Sound rasping chirping ticking growling) -> Map String Int
countOthers =
   Map.unionsWith (+) .
   map (maybe Map.empty (flip Map.singleton 1) .
        mfilter (flip notElem [Label.pause, Label.rumble]) . maybeOther) .
   Fold.toList


data Abstract advert rasping chirping ticking growling =
     NoAdvertisement (Sound rasping chirping ticking growling)
   | Advertisement advert rasping (Maybe chirping)


abstractToLabel :: Abstract time Int chirping Int Int -> String
abstractToLabel cl =
   case cl of
      NoAdvertisement x -> toLabel x
      Advertisement _ numClicks chirp ->
         Label.advertisement ++ ' ' : show numClicks ++
         maybe " end" (const "") chirp