summaryrefslogtreecommitdiff
path: root/trivmix/Trivmix.hs
diff options
context:
space:
mode:
Diffstat (limited to 'trivmix/Trivmix.hs')
-rw-r--r--trivmix/Trivmix.hs28
1 files changed, 14 insertions, 14 deletions
diff --git a/trivmix/Trivmix.hs b/trivmix/Trivmix.hs
index 2e05b13..825e3fa 100644
--- a/trivmix/Trivmix.hs
+++ b/trivmix/Trivmix.hs
@@ -149,22 +149,11 @@ main = execParser opts >>= trivmix
149 149
150trivmix :: Options -> IO () 150trivmix :: Options -> IO ()
151trivmix Options{..} = do 151trivmix Options{..} = do
152 level <- newMVar initialLevel 152 level <- newMVar 0
153 balance <- newMVar initialBalance 153 balance <- newMVar initialBalance
154 level' <- newMVar initialLevel 154 level' <- newMVar initialLevel
155 forkIO $ forever $ do -- Smooth out discontinuity
156 let
157 fps = 200
158 interval = 0.2
159 frames = interval * fps
160 delay = round $ recip fps * 1e6
161 linInt x a b = a * (1 - x) + b * x
162 linInt' x a b = either error id $ asFloat (linInt x) a b
163 mulBalance (bToFloat -> b) x = either error id $ asFloat (*) (Lin . either error id $ refine b) x
164 newLevel <- mulBalance <$> readMVar balance <*> readMVar level
165 currentLevel <- readMVar level'
166 mapM_ (\x -> swapMVar level' (linInt' x currentLevel newLevel) >> threadDelay delay) ([0,recip frames..1] :: [Float])
167 let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles 155 let withFiles = foldl (.) id $ map (\f -> onStateFile f (show initialLevel ++ "\n")) levelFiles
156 ++ map (\f -> onStateFile b (show initialBalance ++ "\n")) balanceFiles
168 withFiles $ withINotify $ \inotify -> do 157 withFiles $ withINotify $ \inotify -> do
169 handleFiles inotify level levelFiles 158 handleFiles inotify level levelFiles
170 handleFiles inotify balance levelFiles 159 handleFiles inotify balance levelFiles
@@ -177,7 +166,18 @@ trivmix Options{..} = do
177 forM_ run $ \script -> 166 forM_ run $ \script ->
178 (callProcess script [client ++ ":" ++ input, client ++ ":" ++ output]) `catch` (\code -> hPutStrLn stderr $ script ++ " failed: " ++ show (code :: ExitCode)) 167 (callProcess script [client ++ ":" ++ input, client ++ ":" ++ output]) `catch` (\code -> hPutStrLn stderr $ script ++ " failed: " ++ show (code :: ExitCode))
179 notifyReady 168 notifyReady
180 forever $ threadDelay 1000000 169 forever $ do -- Smooth out discontinuity
170 let
171 fps = 200
172 interval = 0.2
173 frames = interval * fps
174 delay = round $ recip fps * 1e6
175 linInt x a b = a * (1 - x) + b * x
176 linInt' x a b = either error id $ asFloat (linInt x) a b
177 mulBalance (bToFloat -> b) x = either error id $ asFloat (*) (Lin . either error id $ refine b) x
178 newLevel <- mulBalance <$> readMVar balance <*> readMVar level
179 currentLevel <- readMVar level'
180 mapM_ (\x -> swapMVar level' (linInt' x currentLevel newLevel) >> threadDelay delay) ([0,recip frames..1] :: [Float])
181 181
182mix :: MVar Level -> CFloat -> IO CFloat 182mix :: MVar Level -> CFloat -> IO CFloat
183mix level input = do 183mix level input = do