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 --- trivmix/Trivmix.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'trivmix') 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