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 System.Path ((<.>), (<++>), )
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 <? 2) isAup . Path.toString
getOriginRoot ::
(PathClass.AbsRel ar) => 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