diff options
-rw-r--r-- | RealTimeQueue.hs | 52 | ||||
-rw-r--r-- | axis-of-eval.cabal | 11 | ||||
-rw-r--r-- | rtq.hs | 46 |
3 files changed, 108 insertions, 1 deletions
diff --git a/RealTimeQueue.hs b/RealTimeQueue.hs new file mode 100644 index 0000000..dc40c84 --- /dev/null +++ b/RealTimeQueue.hs | |||
@@ -0,0 +1,52 @@ | |||
1 | module RealTimeQueue where | ||
2 | import BasePrelude hiding ((<>)) | ||
3 | import System.Clock | ||
4 | import Data.IntPSQ as Q | ||
5 | import Control.Monad.IO.Class | ||
6 | import Data.Semigroup | ||
7 | |||
8 | scheduleEvent :: (TimeSpec, event) -> Queue event -> Queue event | ||
9 | scheduleEvent (ts, ev) (Queue q i) = Queue (Q.insert i ts ev q) (i+1) | ||
10 | |||
11 | instance Semigroup (Queue event) where | ||
12 | _ <> q = q | ||
13 | |||
14 | extractScheduledEvents :: TimeSpec -> TimeSpec -> Queue event -> ([(TimeSpec, event)], Queue event) | ||
15 | extractScheduledEvents currentTime timeSpan = getAllScheduled | ||
16 | where | ||
17 | getAllScheduled :: Queue event -> ([(TimeSpec, event)], Queue event) | ||
18 | getAllScheduled queue@(Queue q i) | ||
19 | | isNothing $ getFirstScheduled queue = ([], queue) | ||
20 | | otherwise = let (Just (_, p, v, q')) = minView q | ||
21 | queue' = Queue q' i | ||
22 | in ([(p, v)], queue') <> getAllScheduled queue' | ||
23 | |||
24 | |||
25 | getFirstScheduled :: Queue event -> Maybe (TimeSpec, event) | ||
26 | getFirstScheduled (Queue x _) = case findMin x of | ||
27 | Nothing -> Nothing | ||
28 | Just (_, ts, _) | ts > currentTime + timeSpan -> Nothing | ||
29 | Just (_, ts, ev) -> Just (ts - currentTime, ev) | ||
30 | |||
31 | type QueueRunner m event = TimeSpec -> event -> m () | ||
32 | |||
33 | scheduleEventIO :: MonadIO m => (TimeSpec, event) -> Queue event -> m (Queue event) | ||
34 | scheduleEventIO (ts, ev) queue = do | ||
35 | now <- liftIO $ getTime Monotonic | ||
36 | return $ scheduleEvent (ts + now, ev) queue | ||
37 | |||
38 | runScheduledIO :: MonadIO m => TimeSpec -> QueueRunner m event -> Queue event -> m (Queue event) | ||
39 | runScheduledIO timeSpan runner queue = do | ||
40 | now <- liftIO $ getTime Monotonic | ||
41 | let (events, queue') = extractScheduledEvents now timeSpan queue | ||
42 | forM_ events $ \(ts, ev) -> runner (ts - now) ev | ||
43 | return queue' | ||
44 | |||
45 | |||
46 | createQueue :: Queue event | ||
47 | createQueue = Queue Q.empty 0 | ||
48 | |||
49 | data Queue event = Queue { | ||
50 | intQueue :: IntPSQ TimeSpec event, | ||
51 | nextKey :: Int | ||
52 | } | ||
diff --git a/axis-of-eval.cabal b/axis-of-eval.cabal index acafc72..7a879dd 100644 --- a/axis-of-eval.cabal +++ b/axis-of-eval.cabal | |||
@@ -14,7 +14,7 @@ category: Sound | |||
14 | build-type: Simple | 14 | build-type: Simple |
15 | cabal-version: >=1.10 | 15 | cabal-version: >=1.10 |
16 | 16 | ||
17 | executable axis-of-eval | 17 | executable axis |
18 | default-language: Haskell2010 | 18 | default-language: Haskell2010 |
19 | hs-source-dirs: . | 19 | hs-source-dirs: . |
20 | build-depends: | 20 | build-depends: |
@@ -22,6 +22,15 @@ executable axis-of-eval | |||
22 | main-is: axis.hs | 22 | main-is: axis.hs |
23 | other-modules: AlsaSeq | 23 | other-modules: AlsaSeq |
24 | 24 | ||
25 | executable rtq | ||
26 | default-language: Haskell2010 | ||
27 | hs-source-dirs: . | ||
28 | build-depends: | ||
29 | base, time, clock, base-prelude, psqueues, transformers, mtl, semigroups | ||
30 | main-is: rtq.hs | ||
31 | other-modules: RealTimeQueue | ||
32 | ghc-options: -threaded -W -Wall -O2 | ||
33 | |||
25 | executable midi-dump | 34 | executable midi-dump |
26 | default-language: Haskell2010 | 35 | default-language: Haskell2010 |
27 | hs-source-dirs: . | 36 | hs-source-dirs: . |
@@ -0,0 +1,46 @@ | |||
1 | {-# LANGUAGE FlexibleContexts #-} | ||
2 | {-# LANGUAGE ExplicitForAll #-} | ||
3 | {-# LANGUAGE KindSignatures #-} | ||
4 | |||
5 | import BasePrelude hiding ((.)) | ||
6 | import RealTimeQueue | ||
7 | import Control.Monad.IO.Class | ||
8 | import Control.Monad.State | ||
9 | import System.Clock | ||
10 | |||
11 | data LoopState = LoopState { | ||
12 | _queue :: Queue String | ||
13 | } | ||
14 | |||
15 | main :: IO () | ||
16 | main = void $ runStateT main' (LoopState createQueue) | ||
17 | |||
18 | main' :: StateT LoopState IO () | ||
19 | main' = do | ||
20 | queueAction $ scheduleEventIO (TimeSpec 1 0, "hello world") | ||
21 | queueAction $ scheduleEventIO (TimeSpec 2 0, "hello world") | ||
22 | queueAction $ scheduleEventIO (TimeSpec 3 0, "hello world") | ||
23 | queueAction $ scheduleEventIO (TimeSpec 4 0, "hello world") | ||
24 | mainLoop | ||
25 | |||
26 | queueAction :: forall (m :: * -> *). MonadState LoopState m => (Queue String -> m (Queue String)) -> m () | ||
27 | queueAction act = do | ||
28 | q <- gets _queue | ||
29 | act q >>= modify . const . LoopState | ||
30 | |||
31 | tickTime :: TimeSpec | ||
32 | tickTime = TimeSpec 0 15000 | ||
33 | |||
34 | threadDelay' :: TimeSpec -> IO () | ||
35 | threadDelay' = threadDelay . fromIntegral . timeSpecAsNanoSecs | ||
36 | |||
37 | runner :: TimeSpec -> String -> StateT LoopState IO () | ||
38 | runner delay str = liftIO $ do | ||
39 | threadDelay' delay | ||
40 | putStrLn str | ||
41 | |||
42 | mainLoop :: StateT LoopState IO () | ||
43 | mainLoop = do | ||
44 | queueAction $ runScheduledIO tickTime runner | ||
45 | liftIO $ threadDelay' tickTime | ||
46 | mainLoop | ||