summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--package.yaml4
-rw-r--r--src/Refined/AEq.hs12
-rw-r--r--src/Trivmix/Types.hs16
-rw-r--r--trivmix.nix14
-rw-r--r--trivmix/Trivmix.hs12
5 files changed, 44 insertions, 14 deletions
diff --git a/package.yaml b/package.yaml
index a9e8ddf..e7c5330 100644
--- a/package.yaml
+++ b/package.yaml
@@ -1,5 +1,5 @@
1name: trivmix 1name: trivmix
2version: 4.0.3 2version: 4.1.0
3license: PublicDomain 3license: PublicDomain
4license-file: LICENSE 4license-file: LICENSE
5author: Gregor Kleen <aethoago@141.li> 5author: Gregor Kleen <aethoago@141.li>
@@ -18,6 +18,7 @@ library:
18 - refined >=0.1.2.1 && <1 18 - refined >=0.1.2.1 && <1
19 - scientific >=0.3.5.3 && <1 19 - scientific >=0.3.5.3 && <1
20 - th-lift >=0.7.8 && <1 20 - th-lift >=0.7.8 && <1
21 - ieee754 >=0.8.0 && <1
21 22
22executables: 23executables:
23 trivmix: 24 trivmix:
@@ -41,6 +42,7 @@ executables:
41 - refined >=0.1.2.1 && <1 42 - refined >=0.1.2.1 && <1
42 - scientific >=0.3.5.3 && <1 43 - scientific >=0.3.5.3 && <1
43 - concurrent-output >=1.10.5 && <2 44 - concurrent-output >=1.10.5 && <2
45 - ieee754 >=0.8.0 && <1
44 - trivmix 46 - trivmix
45 adjmix: 47 adjmix:
46 ghc-options: -threaded -O2 48 ghc-options: -threaded -O2
diff --git a/src/Refined/AEq.hs b/src/Refined/AEq.hs
new file mode 100644
index 0000000..0a60679
--- /dev/null
+++ b/src/Refined/AEq.hs
@@ -0,0 +1,12 @@
1{-# OPTIONS_GHC -fno-warn-orphans #-}
2
3module Refined.AEq where
4
5import Data.AEq
6import Refined
7
8import Data.Function (on)
9
10instance AEq a => AEq (Refined p a) where
11 (===) = (===) `on` unrefine
12 (~==) = (~==) `on` unrefine
diff --git a/src/Trivmix/Types.hs b/src/Trivmix/Types.hs
index 5e4660d..347be8e 100644
--- a/src/Trivmix/Types.hs
+++ b/src/Trivmix/Types.hs
@@ -26,12 +26,16 @@ import Data.Default
26import Data.Function (on) 26import Data.Function (on)
27 27
28import Refined 28import Refined
29import Data.AEq
29 30
30import Data.Scientific 31import Data.Scientific
31import Data.Scientific.Lift 32import Data.Scientific.Lift
32 33
34import Refined.AEq
35
33 36
34type Level' = Refined NonNegative Scientific 37type Level' = Refined NonNegative Scientific
38
35data Level = Lin { toLin :: Level' } | DB { toLin :: Level' } 39data Level = Lin { toLin :: Level' } | DB { toLin :: Level' }
36 40
37instance Num Level where 41instance Num Level where
@@ -43,7 +47,7 @@ instance Num Level where
43 fromInteger = Lin . either error id . refine . fromInteger 47 fromInteger = Lin . either error id . refine . fromInteger
44 48
45asScientific :: (Scientific -> Scientific -> Scientific) -> Level -> Level -> Either String Level 49asScientific :: (Scientific -> Scientific -> Scientific) -> Level -> Level -> Either String Level
46asScientific ((`on` toScientific) -> f) x y = toLvl <$> refine (f x y) 50asScientific ((`on` toScientific) -> f) x y = toLvl <$> refineSticky (f x y)
47 where 51 where
48 toLvl 52 toLvl
49 | DB _ <- x = DB 53 | DB _ <- x = DB
@@ -66,7 +70,13 @@ linToDb :: Level' -> Scientific
66linToDb (unrefine -> x) = realToFrac (20 * (logBase 10 $ toRealFloat x) :: Double) 70linToDb (unrefine -> x) = realToFrac (20 * (logBase 10 $ toRealFloat x) :: Double)
67 71
68dBToLin :: Scientific -> Level' 72dBToLin :: Scientific -> Level'
69dBToLin x = either error id . refine . realToFrac $ (10 ** (0.05 * toRealFloat x) :: Double) 73dBToLin x = either error id . refineSticky . realToFrac $ (10 ** (0.05 * toRealFloat x) :: Double)
74
75refineSticky :: Scientific -> Either String Level'
76refineSticky sc@(toRealFloat -> f)
77 | f ~== (1 :: Float) = Right ($$(refineTH 1) :: Level')
78 | f ~== (0 :: Float) = Right ($$(refineTH 0) :: Level')
79 | otherwise = refine sc
70 80
71instance Show Level where 81instance Show Level where
72 show (Lin (unrefine -> x)) = show x 82 show (Lin (unrefine -> x)) = show x
@@ -84,7 +94,7 @@ instance Read Level where
84 return . DB $ dBToLin db 94 return . DB $ dBToLin db
85 parseLin = do 95 parseLin = do
86 lin <- readS_to_Prec readsPrec 96 lin <- readS_to_Prec readsPrec
87 either (const mzero) (return . Lin) $ refine lin 97 either (const mzero) (return . Lin) $ refineSticky lin
88 98
89instance Eq Level where 99instance Eq Level where
90 (==) = (==) `on` toLin 100 (==) = (==) `on` toLin
diff --git a/trivmix.nix b/trivmix.nix
index 690e184..6fc16d9 100644
--- a/trivmix.nix
+++ b/trivmix.nix
@@ -1,22 +1,24 @@
1{ mkDerivation, base, case-insensitive, concurrent-output 1{ mkDerivation, base, case-insensitive, concurrent-output
2, data-default, directory, explicit-exception, filelock, filepath 2, data-default, directory, explicit-exception, filelock, filepath
3, heredoc, hinotify, hpack, jack, optparse-applicative, process 3, heredoc, hinotify, hpack, ieee754, jack, optparse-applicative
4, refined, scientific, stdenv, systemd, th-lift, transformers, unix 4, process, refined, scientific, stdenv, systemd, th-lift
5, transformers, unix
5}: 6}:
6mkDerivation { 7mkDerivation {
7 pname = "trivmix"; 8 pname = "trivmix";
8 version = "4.0.3"; 9 version = "4.1.0";
9 src = ./.; 10 src = ./.;
10 isLibrary = true; 11 isLibrary = true;
11 isExecutable = true; 12 isExecutable = true;
12 libraryHaskellDepends = [ 13 libraryHaskellDepends = [
13 base case-insensitive data-default refined scientific th-lift 14 base case-insensitive data-default ieee754 refined scientific
15 th-lift
14 ]; 16 ];
15 libraryToolDepends = [ hpack ]; 17 libraryToolDepends = [ hpack ];
16 executableHaskellDepends = [ 18 executableHaskellDepends = [
17 base concurrent-output directory explicit-exception filelock 19 base concurrent-output directory explicit-exception filelock
18 filepath heredoc hinotify jack optparse-applicative process refined 20 filepath heredoc hinotify ieee754 jack optparse-applicative process
19 scientific systemd transformers unix 21 refined scientific systemd transformers unix
20 ]; 22 ];
21 preConfigure = "hpack"; 23 preConfigure = "hpack";
22 license = stdenv.lib.licenses.publicDomain; 24 license = stdenv.lib.licenses.publicDomain;
diff --git a/trivmix/Trivmix.hs b/trivmix/Trivmix.hs
index ea8bad3..5075693 100644
--- a/trivmix/Trivmix.hs
+++ b/trivmix/Trivmix.hs
@@ -45,6 +45,7 @@ import Control.Monad
45import Text.Heredoc (str) 45import Text.Heredoc (str)
46 46
47import Refined 47import Refined
48import Data.AEq
48 49
49import Data.Scientific 50import Data.Scientific
50import Trivmix.Types 51import Trivmix.Types
@@ -195,10 +196,10 @@ trivmix Options{..} = do
195 mulBalance (bToScientific -> b) x = either error id $ asScientific (*) (Lin . either error id $ refine b) x 196 mulBalance (bToScientific -> b) x = either error id $ asScientific (*) (Lin . either error id $ refine b) x
196 newLevel <- mulBalance <$> readMVar balance <*> readMVar level 197 newLevel <- mulBalance <$> readMVar balance <*> readMVar level
197 currentLevel <- (\(CFloat f) -> Lin . either error id . refine $ realToFrac f) <$> readMVar level' 198 currentLevel <- (\(CFloat f) -> Lin . either error id . refine $ realToFrac f) <$> readMVar level'
198 case compare currentLevel newLevel of 199 case toCFloat currentLevel ~== toCFloat newLevel of
199 EQ -> threadDelay . round $ interval * 1e6 200 True -> threadDelay . round $ interval * 1e6
200 _ -> do 201 False -> do
201 mapM_ (\x -> (swapMVar level' $! toRealFloat . unrefine . toLin $ linInt' x currentLevel newLevel) >> threadDelay delay) (takeWhile (<= 1) $ iterate (+ recip frames) 0) 202 mapM_ (\x -> (swapMVar level' $! toCFloat $ linInt' x currentLevel newLevel) >> threadDelay delay) (takeWhile (<= 1) $ iterate (+ recip frames) 0)
202 errorConcurrent $ "Finished smooth transition from ‘" ++ show currentLevel ++ "’ to ‘" ++ show newLevel ++ "’.\n" 203 errorConcurrent $ "Finished smooth transition from ‘" ++ show currentLevel ++ "’ to ‘" ++ show newLevel ++ "’.\n"
203 notifyReady 204 notifyReady
204 forever $ threadDelay (round $ watchdogInterval * 1e6) >> notifyWatchdog 205 forever $ threadDelay (round $ watchdogInterval * 1e6) >> notifyWatchdog
@@ -283,3 +284,6 @@ writeLevel :: Show l => FilePath -> l -> IO ()
283writeLevel file level = withFileLock file Exclusive $ const $ do 284writeLevel file level = withFileLock file Exclusive $ const $ do
284 errorConcurrent $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’.\n" 285 errorConcurrent $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’.\n"
285 writeFile file (show level ++ "\n") 286 writeFile file (show level ++ "\n")
287
288toCFloat :: Level -> CFloat
289toCFloat = toRealFloat . unrefine . toLin