audacity (empty) → 0.0
raw patch · 5 files changed
+327/−0 lines, 5 filesdep +audacitydep +basedep +deepseqsetup-changed
Dependencies added: audacity, base, deepseq, filepath, non-empty, soxlib, storablevector, utility-ht
Files
- LICENSE +30/−0
- Setup.lhs +3/−0
- audacity.cabal +56/−0
- example/Concatenate.hs +102/−0
- src/Sound/Audacity/LabelTrack.hs +136/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Henning Thielemann++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Henning Thielemann nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ audacity.cabal view
@@ -0,0 +1,56 @@+Name: audacity+Version: 0.0+Synopsis: Interchange with the Audacity sound signal editor+Description:+ This package provides functions+ for interchange with the Audacity sound signal editor.+ Currently we support import and export of label tracks.+Homepage: http://code.haskell.org/~thielema/audacity+License: BSD3+License-File: LICENSE+Author: Henning Thielemann+Maintainer: haskell@henning-thielemann.de+Category: Sound+Build-Type: Simple+Cabal-Version: >=1.10++Source-Repository this+ Tag: 0.0+ Type: darcs+ Location: http://code.haskell.org/~thielema/audacity++Source-Repository head+ Type: darcs+ Location: http://code.haskell.org/~thielema/audacity++Flag buildExamples+ description: Build example executables+ default: False++Library+ Exposed-Modules:+ Sound.Audacity.LabelTrack+ Build-Depends:+ utility-ht >=0.0.10 && <0.1,+ deepseq >=1.3 && <1.5,+ base >=4.5 && <4.9+ Hs-Source-Dirs: src+ Default-Language: Haskell2010+ GHC-Options: -Wall++Executable sox-concat+ Main-Is: Concatenate.hs+ Hs-Source-Dirs: example+ Default-Language: Haskell2010+ GHC-Options: -Wall+ If flag(buildExamples)+ Build-Depends:+ audacity,+ soxlib >=0.0 && <0.1,+ storablevector >=0.2.9 && <0.3,+ filepath >=1.3 && <1.5,+ non-empty >=0.1.3 && <0.3,+ utility-ht >=0.0.10 && <0.1,+ base+ Else+ Buildable: False
+ example/Concatenate.hs view
@@ -0,0 +1,102 @@+module Main where++import qualified Sound.Audacity.LabelTrack as LabelTrack+import qualified Sound.SoxLib as SoxLib++import qualified Data.StorableVector.Lazy as SVL+import Foreign.Storable (peek, )++import Control.Monad (when, liftM2, )++import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import Data.Traversable (forM, )+import Data.NonEmpty ((!:), )+import Data.Maybe (fromMaybe, )++import qualified System.FilePath as FilePath+import qualified System.Exit as Exit+import qualified System.IO as IO+import System.Environment (getArgs, )+import System.FilePath ((<.>), )+import Text.Printf (printf, )++import Data.Int (Int32, )++++exitFailureMsg :: String -> IO a+exitFailureMsg msg = do+ IO.hPutStrLn IO.stderr msg+ Exit.exitFailure+++defaultSampleRate :: SoxLib.Rate+defaultSampleRate = 44100++withSound ::+ FilePath ->+ (SoxLib.Format SoxLib.ReadMode ->+ Maybe SoxLib.Rate -> Int -> SVL.Vector Int32 -> IO a) ->+ IO a+withSound path act =+ SoxLib.withRead SoxLib.defaultReaderInfo path $ \fmtPtr -> do+ fmt <- peek fmtPtr+ let sigInfo = SoxLib.signalInfo fmt+ numChan = fromMaybe 1 $ SoxLib.channels sigInfo+ rate = SoxLib.rate sigInfo+ act fmt rate numChan =<<+ SoxLib.readStorableVectorLazy fmtPtr+ (case SVL.defaultChunkSize of+ SVL.ChunkSize size -> SVL.ChunkSize $ numChan * size)+++writerInfoFromFormat ::+ SoxLib.Format mode -> SoxLib.WriterInfo+writerInfoFromFormat fmtIn =+ SoxLib.defaultWriterInfo {+ SoxLib.writerSignalInfo = Just $ SoxLib.signalInfo fmtIn+ }+++run :: NonEmpty.T [] FilePath -> FilePath -> IO ()+run neInputs@(NonEmpty.Cons input0 inputs) output = do+ let write fmtOut numChan sig = do+ SoxLib.writeStorableVectorLazy fmtOut sig+ return $! div (SVL.length sig) numChan+ (rate, lengths) <-+ withSound input0 $ \fmtIn rate0 numChan0 sig0 ->+ SoxLib.withWrite (writerInfoFromFormat fmtIn) output $ \fmtOut ->+ fmap ((,) rate0) $+ liftM2 NonEmpty.Cons+ (write fmtOut numChan0 sig0)+ (forM inputs $ \input ->+ withSound input $ \ _fmtIn rate numChan sig -> do+ let showRate = maybe "<no rate>" show+ when (rate0 /= rate) $+ ioError $ userError $+ printf "%s: rate %s differs from initial rate %s"+ input (showRate rate) (showRate rate0)+ when (numChan0 /= numChan) $+ ioError $ userError $+ printf "%s: number channels (%d) differs from initial input (%d)"+ input numChan numChan0+ write fmtOut numChan sig)+ LabelTrack.writeFileInt+ (fromMaybe defaultSampleRate rate)+ (FilePath.dropExtension output <.> "txt") $+ LabelTrack.fromAdjacentChunks $+ NonEmpty.flatten $ NonEmptyC.zip lengths $+ fmap FilePath.takeBaseName neInputs+++main :: IO ()+main = do+ args <- getArgs++ case args of+ arg0 : arg1 : remArgs ->+ case NonEmpty.viewR $ arg0 !: arg1 !: remArgs of+ (inputs, output) -> SoxLib.formatWith $ run inputs output+ [_] -> exitFailureMsg "output file missing"+ [] -> exitFailureMsg "input and output files missing"
+ src/Sound/Audacity/LabelTrack.hs view
@@ -0,0 +1,136 @@+module Sound.Audacity.LabelTrack where++import Text.Read.HT (maybeRead)+import Text.Printf (printf)++import Control.DeepSeq (NFData, rnf)+import Control.Monad (zipWithM)++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.Monoid as Mn+import qualified Data.List.HT as ListHT+import Data.Tuple.HT (mapFst, mapSnd, mapPair)++import qualified Prelude as P+import Prelude hiding (readFile, writeFile)+++newtype T time label = Cons {decons :: [Interval time label]}++type Interval time label = ((time, time), label)+++instance Functor (T time) where+ fmap f = Cons . map (mapSnd f) . decons++instance Fold.Foldable (T time) where+ foldMap f = Fold.foldMap (f . snd) . decons++instance Trav.Traversable (T time) where+ sequenceA =+ fmap Cons . Trav.traverse (\(bnd, label) -> fmap ((,) bnd) label) . decons++instance Mn.Monoid (T time label) where+ mempty = empty+ mappend (Cons xs) (Cons ys) = Cons $ xs ++ ys+ mconcat = Cons . concatMap decons++instance (NFData time, NFData label) => NFData (T time label) where+ rnf = rnf . decons+++empty :: T time label+empty = Cons []++singleton :: (time,time) -> label -> T time label+singleton bnds label = Cons [(bnds, label)]+++fromAdjacentChunks ::+ (Num time) => [(time, label)] -> T time label+fromAdjacentChunks =+ Cons . snd .+ Trav.mapAccumL (\t0 (d, lab) -> let t1=t0+d in (t1, ((t0,t1), lab))) 0+++lift ::+ ([Interval time0 label0] -> [Interval time1 label1]) ->+ T time0 label0 -> T time1 label1+lift f (Cons xs) = Cons $ f xs++lift2 ::+ ([Interval time0 label0] -> [Interval time1 label1] -> [Interval time2 label2]) ->+ T time0 label0 -> T time1 label1 -> T time2 label2+lift2 f (Cons xs) (Cons ys) = Cons $ f xs ys++{- |+Format the times using a comma,+which is certainly only correct in German locale.+-}+formatTime :: (RealFrac time) => time -> String+formatTime t =+ let million = 10^(6::Int)+ (seconds,micros) = divMod (round (t * fromInteger million)) million+ in printf "%d,%06d" seconds micros++{- |+You must make sure, that the time mapping function preserves the order.+This is not checked.+-}+mapTime :: (time0 -> time1) -> T time0 label -> T time1 label+mapTime f = Cons . map (mapFst $ mapPair (f, f)) . decons++realTimes ::+ (Fractional time) =>+ time -> T Int String -> T time String+realTimes sampleRate =+ mapTime (\t -> fromIntegral t / sampleRate)++writeFile :: (RealFrac time) => FilePath -> T time String -> IO ()+writeFile path intervals =+ P.writeFile path $ unlines $+ flip map (decons $ mapTime formatTime intervals) $ \((from,to),label) ->+ printf "%s\t%s\t%s" from to label++writeFileInt ::+ (RealFrac time) =>+ time -> FilePath -> T Int String -> IO ()+writeFileInt sampleRate path =+ writeFile path . realTimes sampleRate+++parseTime :: (Fractional time) => String -> Maybe time+parseTime str =+ case break (','==) str of+ (intStr, ',':fracStr) -> do+ int <- maybeRead intStr+ frac <- maybeRead fracStr+ return $+ fromInteger int ++ fromInteger frac / fromInteger (10 ^ length fracStr)+ (intStr, []) -> fmap fromInteger $ maybeRead intStr+ (_, _:_) -> error "break seems to match other characters than comma"++{- |+Read label file in a strict way.+-}+readFile :: (Fractional time) => FilePath -> IO (T time String)+readFile name =+ let parseTimeIO n str =+ case parseTime str of+ Just t -> return t+ Nothing ->+ ioError $ userError $+ printf "%s:%d: \"%s\" is not a number" name n str+ parseLine n ln =+ case ListHT.chop ('\t'==) ln of+ [fromStr, toStr, label] -> do+ from <- parseTimeIO n fromStr+ to <- parseTimeIO n toStr+ return ((from, to), label)+ fields ->+ ioError $ userError $+ printf "%s:%d: expected 3 fields, but got %d"+ name n (length fields)+ in fmap Cons $ zipWithM parseLine [1::Int ..] . lines =<< P.readFile name