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
|
{-# LANGUAGE FlexibleInstances, UndecidableInstances, ViewPatterns, TemplateHaskell, PatternGuards #-}
module Trivmix.Types
( Level'
, Level(Lin), toLin
, toFloat
, asFloat
, Balance(..)
, bToFloat
, bAsFloat
, 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 = id
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 (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 Float }
deriving (Ord, Eq)
bAsFloat :: (Float -> Float -> Float) -> Balance -> Balance -> Either String Balance
bAsFloat f (unrefine . unBalance -> x) (unrefine . unBalance -> y) = fmap Balance . refine $ f x y
bToFloat :: Balance -> Float
bToFloat = unrefine . unBalance
instance Num Balance where
(+) = fmap (either error id) . bAsFloat (+)
(-) = fmap (either error id) . bAsFloat (-)
(*) = fmap (either error id) . bAsFloat (*)
abs = id
signum = Balance . either error id . refine . signum . bToFloat
fromInteger = Balance . either error id . refine . fromInteger
instance Show Balance where
show = show . bToFloat
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
|
