From 19b440fbabf5bc95e97a7a53119ec6218c3639d7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 15 May 2018 23:08:51 +0200 Subject: Be somewhat sticky --- package.yaml | 4 +++- src/Refined/AEq.hs | 12 ++++++++++++ src/Trivmix/Types.hs | 16 +++++++++++++--- trivmix.nix | 14 ++++++++------ trivmix/Trivmix.hs | 12 ++++++++---- 5 files changed, 44 insertions(+), 14 deletions(-) create mode 100644 src/Refined/AEq.hs diff --git a/package.yaml b/package.yaml index a9e8ddf..e7c5330 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: trivmix -version: 4.0.3 +version: 4.1.0 license: PublicDomain license-file: LICENSE author: Gregor Kleen @@ -18,6 +18,7 @@ library: - refined >=0.1.2.1 && <1 - scientific >=0.3.5.3 && <1 - th-lift >=0.7.8 && <1 + - ieee754 >=0.8.0 && <1 executables: trivmix: @@ -41,6 +42,7 @@ executables: - refined >=0.1.2.1 && <1 - scientific >=0.3.5.3 && <1 - concurrent-output >=1.10.5 && <2 + - ieee754 >=0.8.0 && <1 - trivmix adjmix: 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 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Refined.AEq where + +import Data.AEq +import Refined + +import Data.Function (on) + +instance AEq a => AEq (Refined p a) where + (===) = (===) `on` unrefine + (~==) = (~==) `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 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 @@ -43,7 +47,7 @@ instance Num Level where 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) +asScientific ((`on` toScientific) -> f) x y = toLvl <$> refineSticky (f x y) where toLvl | DB _ <- x = DB @@ -66,7 +70,13 @@ 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) +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 @@ -84,7 +94,7 @@ instance Read Level where return . DB $ dBToLin db parseLin = do lin <- readS_to_Prec readsPrec - either (const mzero) (return . Lin) $ refine lin + either (const mzero) (return . Lin) $ refineSticky lin instance Eq Level where (==) = (==) `on` toLin diff --git a/trivmix.nix b/trivmix.nix index 690e184..6fc16d9 100644 --- a/trivmix.nix +++ b/trivmix.nix @@ -1,22 +1,24 @@ { mkDerivation, base, case-insensitive, concurrent-output , data-default, directory, explicit-exception, filelock, filepath -, heredoc, hinotify, hpack, jack, optparse-applicative, process -, refined, scientific, stdenv, systemd, th-lift, transformers, unix +, heredoc, hinotify, hpack, ieee754, jack, optparse-applicative +, process, refined, scientific, stdenv, systemd, th-lift +, transformers, unix }: mkDerivation { pname = "trivmix"; - version = "4.0.3"; + version = "4.1.0"; src = ./.; isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - base case-insensitive data-default refined scientific th-lift + base case-insensitive data-default ieee754 refined scientific + th-lift ]; libraryToolDepends = [ hpack ]; executableHaskellDepends = [ base concurrent-output directory explicit-exception filelock - filepath heredoc hinotify jack optparse-applicative process refined - scientific systemd transformers unix + filepath heredoc hinotify ieee754 jack optparse-applicative process + refined scientific systemd transformers unix ]; preConfigure = "hpack"; 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 import Text.Heredoc (str) import Refined +import Data.AEq import Data.Scientific import Trivmix.Types @@ -195,10 +196,10 @@ trivmix Options{..} = do mulBalance (bToScientific -> b) x = either error id $ asScientific (*) (Lin . either error id $ refine b) x newLevel <- mulBalance <$> readMVar balance <*> readMVar level currentLevel <- (\(CFloat f) -> Lin . either error id . refine $ realToFrac f) <$> readMVar level' - case compare currentLevel newLevel of - EQ -> threadDelay . round $ interval * 1e6 - _ -> do - mapM_ (\x -> (swapMVar level' $! toRealFloat . unrefine . toLin $ linInt' x currentLevel newLevel) >> threadDelay delay) (takeWhile (<= 1) $ iterate (+ recip frames) 0) + case toCFloat currentLevel ~== toCFloat newLevel of + True -> threadDelay . round $ interval * 1e6 + False -> do + mapM_ (\x -> (swapMVar level' $! toCFloat $ linInt' x currentLevel newLevel) >> threadDelay delay) (takeWhile (<= 1) $ iterate (+ recip frames) 0) errorConcurrent $ "Finished smooth transition from ‘" ++ show currentLevel ++ "’ to ‘" ++ show newLevel ++ "’.\n" notifyReady forever $ threadDelay (round $ watchdogInterval * 1e6) >> notifyWatchdog @@ -283,3 +284,6 @@ writeLevel :: Show l => FilePath -> l -> IO () writeLevel file level = withFileLock file Exclusive $ const $ do errorConcurrent $ "Writing out level ‘" ++ (show level) ++ "’ to ‘" ++ file ++ "’.\n" writeFile file (show level ++ "\n") + +toCFloat :: Level -> CFloat +toCFloat = toRealFloat . unrefine . toLin -- cgit v1.2.3