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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
|
{-# LANGUAGE FlexibleInstances, UndecidableInstances, ViewPatterns, TemplateHaskell, PatternGuards #-}
module Trivmix.Types
( Level'
, Level(Lin, toLin)
, toScientific
, asScientific
, Balance(..)
, bToScientific
, bAsScientific
, 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
import Data.Scientific
import Data.Scientific.Lift
type Level' = Refined NonNegative Scientific
data Level = Lin { toLin :: Level' } | DB { toLin :: Level' }
instance Num Level where
(+) = fmap (either error id) . asScientific (+)
(-) = fmap (either error id) . asScientific (-)
(*) = fmap (either error id) . asScientific (*)
abs = id
signum = Lin . either error id . refine . signum . toScientific
fromInteger = Lin . either error id . refine . fromInteger
asScientific :: (Scientific -> Scientific -> Scientific) -> Level -> Level -> Either String Level
asScientific ((`on` toScientific) -> f) x y = toLvl <$> refine (f x y)
where
toLvl
| DB _ <- x = DB
| DB _ <- y = DB
| otherwise = Lin
toScientific :: Level -> Scientific
toScientific = 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' -> Scientific
linToDb (unrefine -> x) = realToFrac (20 * (logBase 10 $ toRealFloat x) :: Double)
dBToLin :: Scientific -> Level'
dBToLin x = either error id . refine . realToFrac $ (10 ** (0.05 * toRealFloat x) :: Double)
instance Show Level where
show (Lin (unrefine -> 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 = do
lin <- readS_to_Prec readsPrec
either (const mzero) (return . Lin) $ refine lin
instance Eq Level where
(==) = (==) `on` toLin
instance Ord Level where
compare = compare `on` toLin
instance Default Level where
def = Lin $$(refineTH 0)
newtype Balance = Balance { unBalance :: Refined ZeroToOne Scientific }
deriving (Ord, Eq)
bAsScientific :: (Scientific -> Scientific -> Scientific) -> Balance -> Balance -> Either String Balance
bAsScientific f (unrefine . unBalance -> x) (unrefine . unBalance -> y) = fmap Balance . refine $ f x y
bToScientific :: Balance -> Scientific
bToScientific = unrefine . unBalance
instance Num Balance where
(+) = fmap (either error id) . bAsScientific (+)
(-) = fmap (either error id) . bAsScientific (-)
(*) = fmap (either error id) . bAsScientific (*)
abs = id
signum = Balance . either error id . refine . signum . bToScientific
fromInteger = Balance . either error id . refine . fromInteger
instance Show Balance where
show = show . bToScientific
instance Read Balance where
readsPrec = readPrec_to_S $ do
b <- readS_to_Prec readsPrec
either (const mzero) (return . Balance) $ refine b
instance Default Balance where
def = Balance $$(refineTH 1)
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
instance Adjustable Balance where
add = (+)
sub = (-)
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
|
