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))