Be somewhat stickyHEADmaster

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 @@
 name: trivmix
-version: 4.0.3
+version: 4.1.0
 license: PublicDomain
 license-file: LICENSE
 author: Gregor Kleen <aethoago@141.li>
@@ -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