module Audacity where import qualified Audacity.TrackName as TrackName import qualified LabelTrack import qualified LabelChain import qualified Named import qualified Parameters as Params import qualified Signal import qualified Rate import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Basic.Binary as Bin import qualified Sound.Audacity.Project.Track.Label as ProjectLabelTrack import qualified Sound.Audacity.Project.Track.Wave.Summary as ProjectWaveSummary import qualified Sound.Audacity.Project.Track.Wave as ProjectWaveTrack import qualified Sound.Audacity.Project as Audacity import qualified Sound.SoxLib as SoxLib import Sox (writeFeatures) import qualified Data.StorableVector.Lazy as SVL import qualified Text.HTML.Tagchup.Parser as TagParser import qualified Text.HTML.Tagchup.Tag as Tag import qualified Text.XML.Basic.Attribute as Attr import qualified Text.XML.Basic.Name.MixedCase as Name import Spreadsheet.Format ((<->), ) import qualified Control.Monad.Exception.Synchronous as ME import Control.Monad.IO.Class (MonadIO, liftIO, ) import Control.Monad.HT ((<=<), ) import Control.Monad (guard, liftM, ) import Control.Applicative ((<$>), ) import qualified Data.Traversable as Trav import qualified Data.List.HT as ListHT import qualified Data.NonEmpty.Class as NonEmptyC import qualified Data.Map as Map import Data.Zip (transposeClip, ) import Data.Traversable (forM, ) import Data.Monoid (mconcat, ) import Data.Maybe.HT (toMaybe, ) import Data.Maybe (mapMaybe, listToMaybe, isJust, ) import qualified System.Path.PartClass as PathClass import qualified System.Path.IO as PathIO import qualified System.Path as Path import qualified System.FilePath.Find as Find import System.FilePath.Find ((~~?), (==?), (), (<++>), ) import Text.Read.HT (maybeRead, ) import Text.Printf (printf, ) zoomWidth :: Double zoomWidth = 850 zoomFullSignal :: (Rate.C rate, CutG.Read signal) => Signal.T rate signal -> Double zoomFullSignal sig = zoomWidth / Signal.duration sig createProject :: Double -> [Audacity.Track] -> Audacity.T createProject zoom tracks = Audacity.deflt { Audacity.zoom_ = zoom, Audacity.tracks_ = tracks } projectLabelTrack :: String -> LabelTrack.T Double String -> Audacity.Track projectLabelTrack name labels = Audacity.LabelTrack (ProjectLabelTrack.deflt { ProjectLabelTrack.name_ = name, ProjectLabelTrack.track_ = labels }) projectLabelChain :: String -> LabelChain.T Double String -> Audacity.Track projectLabelChain name = projectLabelTrack name . LabelTrack.fromLabelChain summary :: SVL.Vector Float -> [ProjectWaveSummary.T] summary = ProjectWaveSummary.sequenceFromStorableVector 262144 summaryDuration :: (Rate.C rate) => Signal.T rate [ProjectWaveSummary.T] -> Double summaryDuration (Signal.Cons rate xs) = Params.toTime rate $ sum $ map ProjectWaveSummary.length_ xs pcmAliasSequenceFromSummary :: (PathClass.AbsRel ar, MonadIO m) => Path.FilePath ar -> Int -> [ProjectWaveSummary.T] -> ProjectWaveSummary.Monad m ProjectWaveTrack.Sequence pcmAliasSequenceFromSummary aliasFile channel sig = do aliasFileAbs <- liftIO $ Path.genericMakeAbsoluteFromCwd aliasFile ProjectWaveTrack.pcmAliasSequenceFromSummary (Path.toString aliasFileAbs) channel sig projectWaveTrack :: (Rate.C rate, PathClass.AbsRel ar, MonadIO m) => Int -> Bool -> (Signal.T rate (Named.T [ProjectWaveSummary.T]), Path.FilePath ar) -> ProjectWaveSummary.Monad m Audacity.Track projectWaveTrack channel active (Signal.Cons rate (Named.Cons name sig), aliasFile) = do sequ <- pcmAliasSequenceFromSummary aliasFile channel sig return $ Audacity.WaveTrack $ ProjectWaveTrack.deflt { ProjectWaveTrack.name_ = name, ProjectWaveTrack.rate_ = round $ Rate.unpack rate, ProjectWaveTrack.mute_ = not active, ProjectWaveTrack.clips_ = [ProjectWaveTrack.Clip { ProjectWaveTrack.offset_ = 0, ProjectWaveTrack.sequence_ = sequ }] } projectWaveTrackFeatures :: (Rate.C rate, PathClass.AbsRel ar, MonadIO m) => (([Float], Signal.T rate [Named.Signal]), Path.FilePath ar) -> ProjectWaveSummary.Monad m [Audacity.Track] projectWaveTrackFeatures ((scales, featSigs), output) = forM (zip3 [0..] scales $ Trav.sequenceA featSigs) $ \(n, scale, featSig) -> projectWaveTrack n False (Signal.map (summary . SVL.map (scale*) <$>) featSig, output) projectWaveTrackInputSummary :: (Rate.C rate, PathClass.AbsRel ar, MonadIO m) => (Signal.T rate [ProjectWaveSummary.T], Path.FilePath ar) -> ProjectWaveSummary.Monad m Audacity.Track projectWaveTrackInputSummary (sig, input) = projectWaveTrack 0 True (Signal.map (Named.Cons TrackName.recording) sig, input) projectWaveTrackInput :: (PathClass.AbsRel ar, MonadIO m) => (Signal.Sox, Path.FilePath ar) -> ProjectWaveSummary.Monad m Audacity.Track projectWaveTrackInput (sig, input) = projectWaveTrackInputSummary (Signal.map (summary . SVL.map Bin.toCanonical) sig, input) projectWaveTrackConcat :: (Rate.C rate, PathClass.AbsRel ar, MonadIO m, NonEmptyC.Zip f, NonEmptyC.Repeat f) => f String -> [(Path.FilePath ar, (Signal.T rate [ProjectWaveSummary.T], f (LabelTrack.T Double String)))] -> ProjectWaveSummary.Monad m (Double, Audacity.Track, f (Audacity.Track), Audacity.Track) projectWaveTrackConcat labelNames sigs = do sequs <- forM sigs $ \(aliasFile, (Signal.Cons _ sig, _)) -> pcmAliasSequenceFromSummary aliasFile 0 sig let durs = map (summaryDuration . fst . snd) sigs let starts = scanl (+) 0 durs setRate <- case map (Rate.unpack . Signal.sampleRate . fst . snd) sigs of [] -> return id rt@(r:rs) -> if all (r==) rs then return $ \track -> track {ProjectWaveTrack.rate_ = round r} else liftIO $ ioError $ userError $ unlines $ ["differing sample rates", show rt] return (sum durs , Audacity.WaveTrack $ setRate $ ProjectWaveTrack.deflt { ProjectWaveTrack.name_ = TrackName.recording, ProjectWaveTrack.clips_ = zipWith ProjectWaveTrack.Clip starts sequs } , NonEmptyC.zipWith projectLabelTrack labelNames $ fmap mconcat $ transposeClip $ zipWith (\start (_,(_,labv)) -> LabelTrack.shift start <$> labv) starts sigs {- zipWith (\dur (_,(_,labv)) -> LabelTrack.trim (0,dur) <$> labv) durs sigs -} , projectLabelChain TrackName.origin $ LabelChain.fromAdjacentChunks $ zip durs $ map (Path.toString . Path.takeBaseName . fst) sigs) writeLabelTrackInt :: (Rate.C rate, PathClass.AbsRel ar) => rate -> Path.FilePath ar -> String -> LabelChain.T Int String -> IO Audacity.Track writeLabelTrackInt rate stem part trackInt = do let track = LabelChain.realTimes rate trackInt LabelChain.writeFile (stem <-> "hmm-labels" <-> part <.> "txt") track return $ projectLabelChain part track writeFeatureTracks :: (PathClass.AbsRel ar, MonadIO m) => SoxLib.Format mode -> Path.FilePath ar -> [Float] -> Signal.T Rate.Feature [Named.Signal] -> IO (ProjectWaveSummary.Monad m [Audacity.Track]) writeFeatureTracks fmtIn output scales featSigs = do writeFeatures fmtIn output scales featSigs return $ projectWaveTrackFeatures ((scales, featSigs), output) waveSummaryEval :: (PathClass.AbsRel ar, Monad m) => Path.FilePath ar -> ProjectWaveSummary.Monad m a -> m ((Path.FilePath ar, Audacity.T -> String), a) waveSummaryEval outputStem summ = do let outputSumDir = outputStem <++> "_data" liftM ((,) (outputStem <.> "aup", \audProj -> Audacity.format (audProj {Audacity.name_ = Path.toString (Path.takeFileName outputSumDir)}) "")) $ ProjectWaveSummary.eval (Path.toString outputSumDir) summ type OriginPaths ar = (Path.RelFile, Path.FilePath ar) maybePCMAliasTag :: (PathClass.AbsRel ar) => Tag.T Name.T String -> Maybe (OriginPaths ar) maybePCMAliasTag tag = do (name, attrs) <- Tag.maybeOpen tag guard $ name == Tag.Name (Name.Cons "pcmaliasblockfile") path <- Path.maybe =<< Attr.lookupLit "aliasfile" attrs return (Path.takeFileName path, path) originsFromOriginTrack :: (PathClass.AbsRel ar) => [Tag.T Name.T String] -> (String -> IO (LabelTrack.T time String)) -> IO [ME.Exceptional String (LabelTrack.Interval time (OriginPaths ar))] originsFromOriginTrack tagsoup lookupTrack = do let fileMap = Map.fromList $ map (\pair -> (Path.toString $ fst pair, pair)) $ mapMaybe maybePCMAliasTag tagsoup origins <- lookupTrack TrackName.origin return $ flip map (LabelTrack.decons origins) $ \(bnds, origin) -> case Map.lookup origin fileMap of Just pair -> ME.Success (bnds, pair) Nothing -> ME.Exception $ printf "missing origin '%s'" origin waveTrackName :: Tag.Name Name.T waveTrackName = Tag.Name (Name.Cons "wavetrack") maybeWaveTrackTag :: Tag.T Name.T String -> Maybe SoxLib.Rate maybeWaveTrackTag tag = do (name, attrs) <- Tag.maybeOpen tag guard $ name == waveTrackName trackName <- Attr.lookupLit "name" attrs guard $ trackName == TrackName.recording maybeRead =<< Attr.lookupLit "rate" attrs maybeWaveTrackCloseTag :: Tag.T Name.T String -> Maybe () maybeWaveTrackCloseTag tag = do name <- Tag.maybeClose tag guard $ name == waveTrackName maybeWaveClipTag :: Tag.T Name.T String -> Maybe Double maybeWaveClipTag tag = do (name, attrs) <- Tag.maybeOpen tag guard $ name == Tag.Name (Name.Cons "waveclip") maybeRead =<< Attr.lookupLit "offset" attrs maybeSequenceTag :: Tag.T Name.T String -> Maybe Integer maybeSequenceTag tag = do (name, attrs) <- Tag.maybeOpen tag guard $ name == Tag.Name (Name.Cons "sequence") maybeRead =<< Attr.lookupLit "numsamples" attrs intervalFromWaveClip :: (PathClass.AbsRel ar) => SoxLib.Rate -> Double -> [Tag.T Name.T String] -> Maybe (LabelTrack.Interval Double (OriginPaths ar)) intervalFromWaveClip rate from tagsoup = do len <- listToMaybe $ mapMaybe maybeSequenceTag tagsoup origin <- listToMaybe $ mapMaybe maybePCMAliasTag tagsoup return ((from, from + fromInteger len / rate), origin) originsFromRecordingTrack :: (PathClass.AbsRel ar0, PathClass.AbsRel ar1) => Path.FilePath ar0 -> [Tag.T Name.T String] -> IO [ME.Exceptional String (LabelTrack.Interval Double (OriginPaths ar1))] originsFromRecordingTrack path tagsoup = do (rate, waveTrackStart) <- case ListHT.segmentBeforeMaybe maybeWaveTrackTag tagsoup of (_, firstTrack : _) -> return firstTrack _ -> ioError $ userError $ printf "%s: no 'recording' wave track found" $ Path.toString path let intervalFromClip (from, clip) = ME.fromMaybe (printf "missing length or origin info for clip starting from %f" from) $ intervalFromWaveClip rate from clip return $ map intervalFromClip $ snd $ ListHT.segmentBeforeMaybe maybeWaveClipTag $ takeWhile (not . isJust . maybeWaveTrackCloseTag) waveTrackStart audacityExt :: String audacityExt = ".aup" dirFromAudPath :: (PathClass.AbsRel ar) => Path.FilePath ar -> Maybe (Path.DirPath ar) dirFromAudPath = (\(base, ext) -> toMaybe (ext==audacityExt) $ Path.dirFromFile base) . Path.splitExtension findAudacityProject :: (PathClass.AbsRel ar) => Path.DirPath ar -> IO [Path.FilePath ar] findAudacityProject = let isAup = Find.fileName ~~? ("*"++audacityExt) &&? Find.depth ==? 2 &&? (Find.fileType ==? Find.RegularFile ||? Find.fileType ==? Find.SymbolicLink) in fmap (map Path.path) . Find.find (Find.depth Path.DirPath ar -> IO Path.AbsDir getOriginRoot input = do let msg = "When searching for root directory of original recordings: " let loop [] = ioError $ userError $ msg ++ "no Audacity project with pointers to original recordings found" loop (aup:aups) = do origs <- originsFromRecordingTrack aup . TagParser.runSoup =<< PathIO.readFile aup case mapMaybe ME.toMaybe origs of [] -> loop aups (_, (_, orig)):_ -> case Path.takeSuperDirectory <=< Path.takeSuperDirectory $ Path.takeDirectory orig of Nothing -> ioError $ userError $ printf "In %s found %s which has no second super directory" (Path.toString aup) (Path.toString orig) Just root -> return root loop =<< findAudacityProject input