implement module RealTimeQueue

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 @@
+module RealTimeQueue where
+import BasePrelude hiding ((<>))
+import System.Clock
+import Data.IntPSQ as Q
+import Control.Monad.IO.Class
+import Data.Semigroup
+
+scheduleEvent :: (TimeSpec, event) -> Queue event -> Queue event
+scheduleEvent (ts, ev) (Queue q i) = Queue (Q.insert i ts ev q) (i+1)
+
+instance Semigroup (Queue event) where
+    _ <> q = q
+
+extractScheduledEvents :: TimeSpec -> TimeSpec -> Queue event -> ([(TimeSpec, event)], Queue event)
+extractScheduledEvents currentTime timeSpan = getAllScheduled
+    where
+        getAllScheduled :: Queue event -> ([(TimeSpec, event)], Queue event)
+        getAllScheduled queue@(Queue q i)
+            | isNothing $ getFirstScheduled queue = ([], queue)
+            | otherwise = let (Just (_, p, v, q')) = minView q
+                              queue' = Queue q' i
+                          in ([(p, v)], queue') <> getAllScheduled queue'
+
+
+        getFirstScheduled :: Queue event -> Maybe (TimeSpec, event)
+        getFirstScheduled (Queue x _) = case findMin x of
+            Nothing -> Nothing
+            Just (_, ts, _) | ts > currentTime + timeSpan -> Nothing
+            Just (_, ts, ev) -> Just (ts - currentTime, ev)
+
+type QueueRunner m event = TimeSpec -> event -> m ()
+
+scheduleEventIO :: MonadIO m => (TimeSpec, event) -> Queue event -> m (Queue event)
+scheduleEventIO (ts, ev) queue = do
+    now <- liftIO $ getTime Monotonic
+    return $ scheduleEvent (ts + now, ev) queue
+
+runScheduledIO :: MonadIO m => TimeSpec -> QueueRunner m event -> Queue event -> m (Queue event)
+runScheduledIO timeSpan runner queue = do
+    now <- liftIO $ getTime Monotonic
+    let (events, queue') = extractScheduledEvents now timeSpan queue
+    forM_ events $ \(ts, ev) -> runner (ts - now) ev
+    return queue'
+
+
+createQueue :: Queue event
+createQueue = Queue Q.empty 0
+
+data Queue event = Queue {
+    intQueue :: IntPSQ TimeSpec event,
+    nextKey :: Int
+}
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
 build-type:          Simple
 cabal-version:       >=1.10
 
-executable axis-of-eval
+executable axis
   default-language: Haskell2010
   hs-source-dirs: .
   build-depends:
@@ -22,6 +22,15 @@ executable axis-of-eval
   main-is: axis.hs
   other-modules: AlsaSeq
 
+executable rtq
+  default-language: Haskell2010
+  hs-source-dirs: .
+  build-depends:
+    base, time, clock, base-prelude, psqueues, transformers, mtl, semigroups
+  main-is: rtq.hs
+  other-modules: RealTimeQueue
+  ghc-options: -threaded -W -Wall -O2
+
 executable midi-dump
   default-language: Haskell2010
   hs-source-dirs: .
diff --git a/rtq.hs b/rtq.hs
new file mode 100644
index 0000000..a47491a
--- /dev/null
+++ b/rtq.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE KindSignatures #-}
+
+import BasePrelude hiding ((.))
+import RealTimeQueue
+import Control.Monad.IO.Class
+import Control.Monad.State
+import System.Clock
+
+data LoopState = LoopState {
+      _queue :: Queue String
+}
+
+main :: IO ()
+main = void $ runStateT main' (LoopState createQueue)
+
+main' :: StateT LoopState IO ()
+main' = do
+    queueAction $ scheduleEventIO (TimeSpec 1 0, "hello world")
+    queueAction $ scheduleEventIO (TimeSpec 2 0, "hello world")
+    queueAction $ scheduleEventIO (TimeSpec 3 0, "hello world")
+    queueAction $ scheduleEventIO (TimeSpec 4 0, "hello world")
+    mainLoop
+
+queueAction :: forall (m :: * -> *). MonadState LoopState m => (Queue String -> m (Queue String)) -> m ()
+queueAction act = do
+    q <- gets _queue
+    act q >>= modify . const . LoopState
+
+tickTime :: TimeSpec
+tickTime = TimeSpec 0 15000
+
+threadDelay' :: TimeSpec -> IO ()
+threadDelay' = threadDelay . fromIntegral . timeSpecAsNanoSecs
+
+runner :: TimeSpec -> String -> StateT LoopState IO ()
+runner delay str = liftIO $ do
+                        threadDelay' delay
+                        putStrLn str
+
+mainLoop :: StateT LoopState IO ()
+mainLoop = do
+  queueAction $ runScheduledIO tickTime runner
+  liftIO $ threadDelay' tickTime
+  mainLoop