summaryrefslogtreecommitdiff
path: root/src/Trivmix/Types.hs
blob: 347be8efe5d50d3764d49e10949b7e212581718e (plain)
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
156
157
158
159
160
161
162
163
164
165
{-# 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.AEq

import Data.Scientific
import Data.Scientific.Lift

import Refined.AEq


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 <$> refineSticky (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 . refineSticky . realToFrac $ (10 ** (0.05 * toRealFloat x) :: Double)

refineSticky :: Scientific -> Either String Level'
refineSticky sc@(toRealFloat -> f)
  | f ~== (1 :: Float) = Right ($$(refineTH 1) :: Level')
  | f ~== (0 :: Float) = Right ($$(refineTH 0) :: Level')
  | otherwise = refine sc

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