module Sound.Audacity.Project.Track.Wave.Summary ( State(State), Monad, eval, Handle, createHandle, deleteHandle, withHandle, usingHandle, T(Cons, length_, limits_, content_), fromBlock, attachStarts, sequenceFromStorableVector, reserve, Limits(Limits, min_, max_, rms_), defltLimits, storeLimits, summary, ) where import qualified Data.StorableVector.Lazy as SVL import qualified Data.StorableVector as SV import Foreign.Storable.Record as Store import Foreign.Storable (Storable (..), ) import qualified Data.List.HT as ListHT import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Tuple.HT (mapPair) import qualified Control.Monad.Trans.State as MS import qualified Control.Monad.Trans.Reader as MR import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad as M import Control.DeepSeq (NFData, rnf, ($!!), ) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Applicative (liftA3, ) import Prelude hiding (Monad, ) newtype State = State Int type Monad m = MR.ReaderT FilePath (MS.StateT State m) eval :: (M.Monad m) => FilePath -> Monad m a -> m a eval :: FilePath -> Monad m a -> m a eval FilePath path = (StateT State m a -> State -> m a) -> State -> StateT State m a -> m a forall a b c. (a -> b -> c) -> b -> a -> c flip StateT State m a -> State -> m a forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a MS.evalStateT (Int -> State State Int 0) (StateT State m a -> m a) -> (Monad m a -> StateT State m a) -> Monad m a -> m a forall b c a. (b -> c) -> (a -> b) -> a -> c . (Monad m a -> FilePath -> StateT State m a) -> FilePath -> Monad m a -> StateT State m a forall a b c. (a -> b -> c) -> b -> a -> c flip Monad m a -> FilePath -> StateT State m a forall r (m :: * -> *) a. ReaderT r m a -> r -> m a MR.runReaderT FilePath path data Handle = Handle FilePath (IORef State) createHandle :: FilePath -> IO Handle createHandle :: FilePath -> IO Handle createHandle FilePath path = (IORef State -> Handle) -> IO (IORef State) -> IO Handle forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (FilePath -> IORef State -> Handle Handle FilePath path) (IO (IORef State) -> IO Handle) -> IO (IORef State) -> IO Handle forall a b. (a -> b) -> a -> b $ State -> IO (IORef State) forall a. a -> IO (IORef a) newIORef (State -> IO (IORef State)) -> State -> IO (IORef State) forall a b. (a -> b) -> a -> b $ Int -> State State Int 0 deleteHandle :: Handle -> IO () deleteHandle :: Handle -> IO () deleteHandle Handle _ = () -> IO () forall (m :: * -> *) a. Monad m => a -> m a return () withHandle :: FilePath -> (Handle -> IO a) -> IO a withHandle :: FilePath -> (Handle -> IO a) -> IO a withHandle FilePath path Handle -> IO a act = FilePath -> IO Handle createHandle FilePath path IO Handle -> (Handle -> IO a) -> IO a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Handle -> IO a act usingHandle :: (MonadIO io) => Handle -> Monad io a -> io a usingHandle :: Handle -> Monad io a -> io a usingHandle (Handle FilePath path IORef State stateRef) Monad io a act = do State oldState <- IO State -> io State forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO State -> io State) -> IO State -> io State forall a b. (a -> b) -> a -> b $ IORef State -> IO State forall a. IORef a -> IO a readIORef IORef State stateRef (a a, State newState) <- (StateT State io a -> State -> io (a, State)) -> State -> StateT State io a -> io (a, State) forall a b c. (a -> b -> c) -> b -> a -> c flip StateT State io a -> State -> io (a, State) forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s) MS.runStateT State oldState (StateT State io a -> io (a, State)) -> StateT State io a -> io (a, State) forall a b. (a -> b) -> a -> b $ (Monad io a -> FilePath -> StateT State io a) -> FilePath -> Monad io a -> StateT State io a forall a b c. (a -> b -> c) -> b -> a -> c flip Monad io a -> FilePath -> StateT State io a forall r (m :: * -> *) a. ReaderT r m a -> r -> m a MR.runReaderT FilePath path Monad io a act IO () -> io () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> io ()) -> IO () -> io () forall a b. (a -> b) -> a -> b $ IORef State -> State -> IO () forall a. IORef a -> a -> IO () writeIORef IORef State stateRef State newState a -> io a forall (m :: * -> *) a. Monad m => a -> m a return a a data T = Cons { T -> Int length_ :: Int, T -> Limits limits_ :: Limits, T -> Vector Limits content_ :: SVL.Vector Limits } deriving Int -> T -> ShowS [T] -> ShowS T -> FilePath (Int -> T -> ShowS) -> (T -> FilePath) -> ([T] -> ShowS) -> Show T forall a. (Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a showList :: [T] -> ShowS $cshowList :: [T] -> ShowS show :: T -> FilePath $cshow :: T -> FilePath showsPrec :: Int -> T -> ShowS $cshowsPrec :: Int -> T -> ShowS Show instance NFData T where rnf :: T -> () rnf (Cons Int len Limits limits Vector Limits dat) = (Int, Limits, Vector Limits) -> () forall a. NFData a => a -> () rnf (Int len, Limits limits, Vector Limits dat) fromBlock :: SVL.Vector Float -> T fromBlock :: Vector Float -> T fromBlock Vector Float block = let sum256 :: [((Float, Float), (Float, Int))] sum256 = (Vector Float -> ((Float, Float), (Float, Int))) -> [Vector Float] -> [((Float, Float), (Float, Int))] forall a b. (a -> b) -> [a] -> [b] map Vector Float -> ((Float, Float), (Float, Int)) accumulate ([Vector Float] -> [((Float, Float), (Float, Int))]) -> [Vector Float] -> [((Float, Float), (Float, Int))] forall a b. (a -> b) -> a -> b $ Int -> Vector Float -> [Vector Float] forall a. Storable a => Int -> Vector a -> [Vector a] SVL.sliceVertical Int 256 Vector Float block sum65536 :: [((Float, Float), (Float, Int))] sum65536 = ([((Float, Float), (Float, Int))] -> ((Float, Float), (Float, Int))) -> [[((Float, Float), (Float, Int))]] -> [((Float, Float), (Float, Int))] forall a b. (a -> b) -> [a] -> [b] map [((Float, Float), (Float, Int))] -> ((Float, Float), (Float, Int)) reduce ([[((Float, Float), (Float, Int))]] -> [((Float, Float), (Float, Int))]) -> [[((Float, Float), (Float, Int))]] -> [((Float, Float), (Float, Int))] forall a b. (a -> b) -> a -> b $ Int -> [((Float, Float), (Float, Int))] -> [[((Float, Float), (Float, Int))]] forall a. Int -> [a] -> [[a]] ListHT.sliceVertical Int 256 [((Float, Float), (Float, Int))] sum256 accumTmp :: ((Float, Float), (Float, Int)) accumTmp@((Float, Float) _, (Float _, Int len)) = [((Float, Float), (Float, Int))] -> ((Float, Float), (Float, Int)) reduce [((Float, Float), (Float, Int))] sum65536 in Cons :: Int -> Limits -> Vector Limits -> T Cons { length_ :: Int length_ = Int len, limits_ :: Limits limits_ = ((Float, Float), (Float, Int)) -> Limits limitsFromAccumulators ((Float, Float), (Float, Int)) accumTmp, content_ :: Vector Limits content_ = [Vector Limits] -> Vector Limits forall a. Storable a => [Vector a] -> Vector a SVL.fromChunks ([Vector Limits] -> Vector Limits) -> [Vector Limits] -> Vector Limits forall a b. (a -> b) -> a -> b $ ([Limits] -> Vector Limits forall a. Storable a => [a] -> Vector a SV.pack ([Limits] -> Vector Limits) -> [Limits] -> Vector Limits forall a b. (a -> b) -> a -> b $ (((Float, Float), (Float, Int)) -> Limits) -> [((Float, Float), (Float, Int))] -> [Limits] forall a b. (a -> b) -> [a] -> [b] map ((Float, Float), (Float, Int)) -> Limits limitsFromAccumulators [((Float, Float), (Float, Int))] sum256) Vector Limits -> [Vector Limits] -> [Vector Limits] forall a. a -> [a] -> [a] : ([Limits] -> Vector Limits forall a. Storable a => [a] -> Vector a SV.pack ([Limits] -> Vector Limits) -> [Limits] -> Vector Limits forall a b. (a -> b) -> a -> b $ (((Float, Float), (Float, Int)) -> Limits) -> [((Float, Float), (Float, Int))] -> [Limits] forall a b. (a -> b) -> [a] -> [b] map ((Float, Float), (Float, Int)) -> Limits limitsFromAccumulators [((Float, Float), (Float, Int))] sum65536) Vector Limits -> [Vector Limits] -> [Vector Limits] forall a. a -> [a] -> [a] : [] } attachStarts :: [T] -> [(Int, T)] attachStarts :: [T] -> [(Int, T)] attachStarts [T] xs = (Int -> T -> (Int, T)) -> [Int] -> [T] -> [(Int, T)] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (\ Int start T block -> ((,) (Int -> T -> (Int, T)) -> Int -> T -> (Int, T) forall a b. NFData a => (a -> b) -> a -> b $!! Int start) T block) ((Int -> Int -> Int) -> Int -> [Int] -> [Int] forall b a. (b -> a -> b) -> b -> [a] -> [b] scanl Int -> Int -> Int forall a. Num a => a -> a -> a (+) Int 0 ([Int] -> [Int]) -> [Int] -> [Int] forall a b. (a -> b) -> a -> b $ (T -> Int) -> [T] -> [Int] forall a b. (a -> b) -> [a] -> [b] map T -> Int length_ [T] xs) [T] xs sequenceFromStorableVector :: Int -> SVL.Vector Float -> [T] sequenceFromStorableVector :: Int -> Vector Float -> [T] sequenceFromStorableVector Int blockSize = (Vector Float -> T) -> [Vector Float] -> [T] forall a b. (a -> b) -> [a] -> [b] map Vector Float -> T fromBlock ([Vector Float] -> [T]) -> (Vector Float -> [Vector Float]) -> Vector Float -> [T] forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> Vector Float -> [Vector Float] forall a. Storable a => Int -> Vector a -> [Vector a] SVL.sliceVertical Int blockSize reserve :: (M.Monad m) => Monad m State reserve :: Monad m State reserve = StateT State m State -> Monad m State forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a MT.lift (StateT State m State -> Monad m State) -> StateT State m State -> Monad m State forall a b. (a -> b) -> a -> b $ do s :: State s@(State Int n) <- StateT State m State forall (m :: * -> *) s. Monad m => StateT s m s MS.get State -> StateT State m () forall (m :: * -> *) s. Monad m => s -> StateT s m () MS.put (State -> StateT State m ()) -> State -> StateT State m () forall a b. (a -> b) -> a -> b $ Int -> State State (Int nInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) State -> StateT State m State forall (m :: * -> *) a. Monad m => a -> m a return State s data Limits = Limits {Limits -> Float min_, Limits -> Float max_, Limits -> Float rms_ :: Float} deriving Int -> Limits -> ShowS [Limits] -> ShowS Limits -> FilePath (Int -> Limits -> ShowS) -> (Limits -> FilePath) -> ([Limits] -> ShowS) -> Show Limits forall a. (Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a showList :: [Limits] -> ShowS $cshowList :: [Limits] -> ShowS show :: Limits -> FilePath $cshow :: Limits -> FilePath showsPrec :: Int -> Limits -> ShowS $cshowsPrec :: Int -> Limits -> ShowS Show instance NFData Limits where rnf :: Limits -> () rnf (Limits Float ymin Float ymax Float yrms) = (Float, Float, Float) -> () forall a. NFData a => a -> () rnf (Float ymin, Float ymax, Float yrms) defltLimits :: Limits defltLimits :: Limits defltLimits = Limits :: Float -> Float -> Float -> Limits Limits {min_ :: Float min_ = -Float 1, max_ :: Float max_ = Float 1, rms_ :: Float rms_ = Float 0.2} storeLimits :: Store.Dictionary Limits storeLimits :: Dictionary Limits storeLimits = Access Limits Limits -> Dictionary Limits forall r. Access r r -> Dictionary r Store.run (Access Limits Limits -> Dictionary Limits) -> Access Limits Limits -> Dictionary Limits forall a b. (a -> b) -> a -> b $ (Float -> Float -> Float -> Limits) -> Access Limits Float -> Access Limits Float -> Access Limits Float -> Access Limits Limits forall (f :: * -> *) a b c d. Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d liftA3 Float -> Float -> Float -> Limits Limits ((Limits -> Float) -> Access Limits Float forall a r. Storable a => (r -> a) -> Access r a Store.element Limits -> Float min_) ((Limits -> Float) -> Access Limits Float forall a r. Storable a => (r -> a) -> Access r a Store.element Limits -> Float max_) ((Limits -> Float) -> Access Limits Float forall a r. Storable a => (r -> a) -> Access r a Store.element Limits -> Float rms_) instance Storable Limits where sizeOf :: Limits -> Int sizeOf = Dictionary Limits -> Limits -> Int forall r. Dictionary r -> r -> Int Store.sizeOf Dictionary Limits storeLimits alignment :: Limits -> Int alignment = Dictionary Limits -> Limits -> Int forall r. Dictionary r -> r -> Int Store.alignment Dictionary Limits storeLimits peek :: Ptr Limits -> IO Limits peek = Dictionary Limits -> Ptr Limits -> IO Limits forall r. Dictionary r -> Ptr r -> IO r Store.peek Dictionary Limits storeLimits poke :: Ptr Limits -> Limits -> IO () poke = Dictionary Limits -> Ptr Limits -> Limits -> IO () forall r. Dictionary r -> Ptr r -> r -> IO () Store.poke Dictionary Limits storeLimits summary :: Int -> SVL.Vector Float -> SV.Vector Limits summary :: Int -> Vector Float -> Vector Limits summary Int chunkSize = [Limits] -> Vector Limits forall a. Storable a => [a] -> Vector a SV.pack ([Limits] -> Vector Limits) -> (Vector Float -> [Limits]) -> Vector Float -> Vector Limits forall b c a. (b -> c) -> (a -> b) -> a -> c . (Vector Float -> Limits) -> [Vector Float] -> [Limits] forall a b. (a -> b) -> [a] -> [b] map (((Float, Float), (Float, Int)) -> Limits limitsFromAccumulators (((Float, Float), (Float, Int)) -> Limits) -> (Vector Float -> ((Float, Float), (Float, Int))) -> Vector Float -> Limits forall b c a. (b -> c) -> (a -> b) -> a -> c . Vector Float -> ((Float, Float), (Float, Int)) accumulate) ([Vector Float] -> [Limits]) -> (Vector Float -> [Vector Float]) -> Vector Float -> [Limits] forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> Vector Float -> [Vector Float] forall a. Storable a => Int -> Vector a -> [Vector a] SVL.sliceVertical Int chunkSize reduce :: [((Float, Float), (Float, Int))] -> ((Float, Float), (Float, Int)) reduce :: [((Float, Float), (Float, Int))] -> ((Float, Float), (Float, Int)) reduce [((Float, Float), (Float, Int))] xs = let (([Float] xmin, [Float] xmax), ([Float] xsqr, [Int] len)) = ([(Float, Float)] -> ([Float], [Float]), [(Float, Int)] -> ([Float], [Int])) -> ([(Float, Float)], [(Float, Int)]) -> (([Float], [Float]), ([Float], [Int])) forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d) mapPair ([(Float, Float)] -> ([Float], [Float]) forall a b. [(a, b)] -> ([a], [b]) unzip, [(Float, Int)] -> ([Float], [Int]) forall a b. [(a, b)] -> ([a], [b]) unzip) (([(Float, Float)], [(Float, Int)]) -> (([Float], [Float]), ([Float], [Int]))) -> ([(Float, Float)], [(Float, Int)]) -> (([Float], [Float]), ([Float], [Int])) forall a b. (a -> b) -> a -> b $ [((Float, Float), (Float, Int))] -> ([(Float, Float)], [(Float, Int)]) forall a b. [(a, b)] -> ([a], [b]) unzip [((Float, Float), (Float, Int))] xs in (([Float] -> Float forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a minimum [Float] xmin, [Float] -> Float forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a maximum [Float] xmax), ([Float] -> Float forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a sum [Float] xsqr, [Int] -> Int forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a sum [Int] len)) limitsFromAccumulators :: ((Float, Float), (Float, Int)) -> Limits limitsFromAccumulators :: ((Float, Float), (Float, Int)) -> Limits limitsFromAccumulators ((Float xmin, Float xmax), (Float xsqr, Int len)) = Float -> Float -> Float -> Limits Limits Float xmin Float xmax (Float -> Float forall a. Floating a => a -> a sqrt (Float xsqr Float -> Float -> Float forall a. Fractional a => a -> a -> a / Int -> Float forall a b. (Integral a, Num b) => a -> b fromIntegral Int len)) accumulate :: SVL.Vector Float -> ((Float, Float), (Float, Int)) accumulate :: Vector Float -> ((Float, Float), (Float, Int)) accumulate Vector Float chunk = (((Float -> Float -> Float) -> Float -> Vector Float -> Float forall b a. Storable b => (a -> b -> a) -> a -> Vector b -> a SVL.foldl' Float -> Float -> Float forall a. Ord a => a -> a -> a min Float 1 Vector Float chunk, (Float -> Float -> Float) -> Float -> Vector Float -> Float forall b a. Storable b => (a -> b -> a) -> a -> Vector b -> a SVL.foldl' Float -> Float -> Float forall a. Ord a => a -> a -> a max (-Float 1) Vector Float chunk), ((Float -> Float -> Float) -> Float -> Vector Float -> Float forall b a. Storable b => (a -> b -> a) -> a -> Vector b -> a SVL.foldl' Float -> Float -> Float forall a. Num a => a -> a -> a (+) Float 0 ((Float -> Float) -> Vector Float -> Vector Float forall x y. (Storable x, Storable y) => (x -> y) -> Vector x -> Vector y SVL.map (Float -> Int -> Float forall a b. (Num a, Integral b) => a -> b -> a ^(Int 2::Int)) Vector Float chunk), Vector Float -> Int forall a. Vector a -> Int SVL.length Vector Float chunk))