wav-info/level.hs

{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}

-- Создан:  Ср 28 сен 2016 10:18:53
-- Изменен: Пт 14 окт 2016 17:53:23

import System.Console.CmdArgs
import System.Environment
import System.Directory
import System.Exit
import Data.WAVE
import Data.Char
import Data.List
import Data.List.Split
import Control.Monad

-- =============================================================================

-- Среднее значение списка
median :: Fractional a => [a] -> a
median l = let (t,n) = foldl' (\(b,c) a -> (a+b,c+1)) (0,0) l in t/n

--
everyN :: Int -> [Double] -> [[Double]]
everyN n list = [(n+n) ## drop (x-1) list | x <- [1, n..length list]]

-- Перевод между типами
convert :: (Show a, Read c) => a -> c
convert = read . show

-- Проверка на пустую строку
notEmpty :: String -> Bool
notEmpty = (/=) (show "")

-- Проверка на действительное ненулевое значение
notZero :: RealFloat a => a -> Bool
notZero x = (not $ isNaN x) && (x /= 0)

-- Синтаксический сахар
(<@) = map     -- a <@ b = map a b
(<#) = filter  -- a <# b = filter a b
(##) = take    -- n##b = take n b
(//) = drop    -- n//b = drop n b

-- =============================================================================

-- Чтение данных аудиофайла
audioread :: WAVE -> [[Double]]
audioread = map samplesToDouble . waveSamples
	where samplesToDouble (l:r:[]) = [sampleToDouble l, sampleToDouble r]

--Выбор канала из пары
getChannel :: [Char] -> [[Double]] -> [Double]
getChannel ch = map selectChannel where
	selectChannel (l:r:[])  | ch == "R" = r
				| ch == "L" = l
				| otherwise  = l

-- k десятичных логарифмов
float2db :: (RealFloat a, Integral b) => b -> a -> a
float2db k x
	| notZero x = fromIntegral k * (logBase 10 x)
	| otherwise = 0

-- Пиковое значение уровня сигнала на отрезке
peak :: (Ord a, Floating a) => [a] -> a
peak [] = acos(1) -- NaN
peak xs = maximum xs

-- Вычисление уровня сигнала
calcLevel :: [Char] -> Int -> [Double] -> Int
calcLevel vu = case (toLower <@ vu) of
		"lufs" -> calcLevelLUFS
		"db"   -> calcLevelDb

-- Вычисление уровня сигнала / Db
calcLevelDb :: Int -> [Double] -> Int
calcLevelDb fs samples = case dd of
		[] -> -52 -- Неслышимый звук
		_  -> round (median dd)
	where
		dd = notZero <# map (float2db 20 . peak) slices
		slices = splitWhen (== 0) $ take fs samples

-- Вычисление уровня сигнала / LUFS
calcLevelLUFS :: Int -> [Double] -> Int
calcLevelLUFS fs samples = round (median $ getlufs <@ chunks)
	where
		getlufs l = float2db 10 (1 / fd' * (sum $ map (^2) l))
		chunks = everyN fd $ take fs samples
		fd  = fs `div` 10
		fd' = convert fd :: Double

-- Вычисление значения фазы
calcPhase :: (Ord a, Fractional a) => [[a]] -> a
calcPhase samples
		| sum [ abs l + abs r | [l,r] <- samples] < 0.01 = 0
		| otherwise = median (map ph (zip3 samples (1//samples) (2//samples))) where
	ph ([0,0], [l2,r2], [l3,r3])    | (signum l2 /= signum r2) && (signum l3 /= signum r3) = 0
					| otherwise = 1

	ph ([l1,r1], _, _)              | (l1 == 0 && r1 /= 0) || ((r1 == 0) && (l1 /= 0)) = 0
					| otherwise =
						if (abs l1) >= (abs r1) then
							2 * (l1 + r1) / (2 * l1) - 1
						else
							2 * (l1 + r1) / (2 * r1) - 1

-- =============================================================================

-- Параметры
data Audioread = Audioread {
		info    :: String,
		samples :: Int,
		channel :: String,
		file    :: String,
		vu      :: String,
		title   :: Int
	} deriving (Show, Data,Typeable)

-- Стандартные значения и описания параметров
defaultOptions :: IO Audioread
defaultOptions = cmdArgs $ Audioread {
			file    = "none" &= typ  "FILE.WAV" &= help "File for analysis",
			info    = "none" &= typ  "samples,phase,db,lufs" &= help "Type of information",
			samples = 1200   &= typ  "12000"    &= help "Number of samples for analysis",
			channel = "L"    &= typ  "L/R"      &= help "Channel from stereo stream",
			title   = 0      &= typ  "1/0"      &= help "File for analysis",
			vu      = "db"   &= typ  "db/lufs"  &= help "Type of vu scale"
		} &= summary "audioread v0.2: information about audiofiles"

-- Вывод строки с префиксом и суффиксом
describe :: (Show s) => Int -> String -> s -> String -> IO ()
describe o p ms s = let message = show ms in do
			when (o == 1) $ putStr $ p
			when (notEmpty message) $ putStr message
			when (o == 1) $ putStr $ s
			putStrLn ""

main :: IO ()
main = do
	args <- getArgs
	cmd <- (if null args then withArgs ["--help"] else id) defaultOptions

	unless (isInfixOf ".wav" $ file cmd) $ do
		putStrLn "ERROR: You must specify a correct filename."
		exitFailure

	d <- getWAVEFile $ file cmd
	let w = samples cmd ## audioread d

	let exec fx = do
		describe (title cmd) ("\n---[ " ++ fx) "" (" ]:")
		case fx of
			"samples" -> mapM_ print $ getChannel (toUpper <@ channel cmd) w
			"phase"   -> print $ calcPhase w
			"level"   -> do
				describe (title cmd) "L: "
					(calcLevel (vu cmd) (samples cmd) (getChannel "L" w)) (vu cmd)
				describe (title cmd) "R: "
					(calcLevel (vu cmd) (samples cmd) (getChannel "R" w)) (vu cmd)
			_         -> putStrLn $ "WARNING: Unknown type of information: " ++ fx ++ "\n"

	mapM_ exec (splitOn "," $ info cmd)