summaryrefslogtreecommitdiff
path: root/trivmix/Trivmix.hs
diff options
context:
space:
mode:
Diffstat (limited to 'trivmix/Trivmix.hs')
-rw-r--r--trivmix/Trivmix.hs9
1 files changed, 4 insertions, 5 deletions
diff --git a/trivmix/Trivmix.hs b/trivmix/Trivmix.hs
index 7743246..2e05b13 100644
--- a/trivmix/Trivmix.hs
+++ b/trivmix/Trivmix.hs
@@ -42,12 +42,11 @@ import Data.Function
42import Control.Monad 42import Control.Monad
43 43
44import Text.Heredoc (str) 44import Text.Heredoc (str)
45import Refined 45
46import Refined (refine)
46 47
47import Trivmix.Types 48import Trivmix.Types
48 49
49type Balance = Refined ZeroToOne Float
50
51data Options = Options 50data Options = Options
52 { input :: String 51 { input :: String
53 , output :: String 52 , output :: String
@@ -86,7 +85,7 @@ optionParser = Options
86 <*> option auto ( long "initial-balance" 85 <*> option auto ( long "initial-balance"
87 <> metavar "BALANCE" 86 <> metavar "BALANCE"
88 <> help "Initial value for balance" 87 <> help "Initial value for balance"
89 <> value ($$(refineTH 1.0) :: Balance) 88 <> value def
90 <> showDefault 89 <> showDefault
91 ) 90 )
92 <*> many ( strOption ( long "run" 91 <*> many ( strOption ( long "run"
@@ -161,7 +160,7 @@ trivmix Options{..} = do
161 delay = round $ recip fps * 1e6 160 delay = round $ recip fps * 1e6
162 linInt x a b = a * (1 - x) + b * x 161 linInt x a b = a * (1 - x) + b * x
163 linInt' x a b = either error id $ asFloat (linInt x) a b 162 linInt' x a b = either error id $ asFloat (linInt x) a b
164 mulBalance (unrefine -> b) x = either error id $ asFloat (*) (Lin . either error id $ refine b) x 163 mulBalance (bToFloat -> b) x = either error id $ asFloat (*) (Lin . either error id $ refine b) x
165 newLevel <- mulBalance <$> readMVar balance <*> readMVar level 164 newLevel <- mulBalance <$> readMVar balance <*> readMVar level
166 currentLevel <- readMVar level' 165 currentLevel <- readMVar level'
167 mapM_ (\x -> swapMVar level' (linInt' x currentLevel newLevel) >> threadDelay delay) ([0,recip frames..1] :: [Float]) 166 mapM_ (\x -> swapMVar level' (linInt' x currentLevel newLevel) >> threadDelay delay) ([0,recip frames..1] :: [Float])