1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
{-# LANGUAGE FlexibleInstances, UndecidableInstances, ViewPatterns, TemplateHaskell, PatternGuards #-}
module Trivmix.Types
( Level'
, Level(Lin), toLin
, toFloat
, asFloat
, Adjustment(..)
, doAdjustment
, module Data.Default
) where
import Data.Fixed
import Data.CaseInsensitive ( CI )
import qualified Data.CaseInsensitive as CI
import Text.ParserCombinators.ReadPrec
import Control.Applicative
import Control.Monad
import Data.Default
import Data.Function (on)
import Refined
type Level' = Refined NonNegative Float
data Level = Lin { toLin :: Level' } | DB { toLin :: Level' }
instance Num Level where
(+) = fmap (either error id) . asFloat (+)
(-) = fmap (either error id) . asFloat (-)
(*) = fmap (either error id) . asFloat (*)
abs = Lin . toLin
signum = Lin . either error id . refine . signum . toFloat
fromInteger = Lin . either error id . refine . fromInteger
asFloat :: (Float -> Float -> Float) -> Level -> Level -> Either String Level
asFloat ((`on` toFloat) -> f) x y = toLvl <$> refine (f x y)
where
toLvl
| DB _ <- x = DB
| DB _ <- y = DB
| otherwise = Lin
toFloat :: Level -> Float
toFloat = unrefine . toLin
withPrec :: (Num a, RealFrac a, HasResolution b) => a -> Fixed b
withPrec x = withResolution $ \p' -> MkFixed $ toInteger $ round $ x * (fromInteger p')
withType :: (p a -> f a) -> f a
withType f = f undefined
withResolution :: (HasResolution a) => (Integer -> f a) -> f a
withResolution f = withType (f . resolution)
linToDb :: Level' -> Float
linToDb (unrefine -> x) = 20 * (logBase 10 x)
dBToLin :: Float -> Level'
dBToLin x = either error id . refine $ 10 ** (0.05 * x)
instance Show Level where
show (Lin x) = show x
show (DB (linToDb -> x)) = (show $ (withPrec x :: Milli)) ++ "dB"
instance Read Level where
readsPrec = readPrec_to_S $ parseDb <|> parseLin
where
parseDb = do
db <- readS_to_Prec readsPrec
let
unit@(length -> lU) = "dB"
unit' <- forM [1..lU] $ const get
guard $ ((==) `on` CI.mk) unit unit'
return . DB $ dBToLin db
parseLin = Lin <$> readS_to_Prec readsPrec
instance Eq Level where
(==) = (==) `on` toLin
instance Default Level where
def = Lin $$(refineTH 0)
data Adjustment a = Set a
| Add a
| Sub a
deriving (Show, Eq)
class Adjustable a where
add :: a -> a -> a
sub :: a -> a -> a
-- instance Num a => Adjustable a where
-- add = (+)
-- sub = (-)
instance Adjustable Level where
add (DB x) (DB y) = DB $ dBToLin $ ((+) `on` linToDb) x y
add x y = x + y
sub (DB x) (DB y) = DB $ dBToLin $ ((-) `on` linToDb) x y
sub x y = x - y
doAdjustment :: Adjustable a => a -> Adjustment a -> a
doAdjustment _ (Set y) = y
doAdjustment x (Add y) = add x y
doAdjustment x (Sub y) = sub x y
|
