1 files changed, 70 insertions, 0 deletions

diff --git a/RingBuffer.hs b/RingBuffer.hs
new file mode 100644
index 0000000..b2779d7
--- /dev/null
+++ b/RingBuffer.hs
@@ -0,0 +1,70 @@
+module RingBuffer where
+
+import Control.Monad
+import Data.Int
+import Data.IORef
+
+data TargetBuffer u = TargetBuffer
+    { -- | Called whenever the rBack or rSize changes.  The purpose is so that
+      -- some other state, such as an OpenGL vertex buffer object, can remain in
+      -- sync.
+      syncBuffer :: (Int32 -> [(Int32,Int32)]) -> IO ()
+      -- | This updates the data associated with a particular index (usually
+      -- rBack).  The update specification /u/ may be a value or a set of
+      -- key-value pairs or whatever is most convenient way to instruct the
+      -- target representation to update itself.
+    , updateBuffer :: Int -> u -> IO ()
+    }
+
+data RingBuffer u = RingBuffer
+    { rBack        :: IORef Int
+    , rSize        :: IORef Int
+    , ringCapacity :: Int
+    , rBuffer      :: TargetBuffer u
+    }
+
+newRing :: Int -> IO (TargetBuffer u) -> IO (RingBuffer u)
+newRing sz newBuffer = do
+    backRef <- newIORef 0
+    sizeRef <- newIORef 0
+    b <- newBuffer
+    let r = RingBuffer
+            { rBack        = backRef
+            , rSize        = sizeRef
+            , ringCapacity = sz
+            , rBuffer      = b
+            }
+    syncRing r
+    return r
+
+syncRing :: RingBuffer u -> IO ()
+syncRing r = do
+    size <- fromIntegral <$> readIORef (rSize r)
+    back <- fromIntegral <$> readIORef (rBack r)
+    let mask 0   = []
+        mask cnt
+            | cnt==size = [(0,cnt)]
+            | otherwise = case cnt + back - size of
+                front | front > cnt -> [(front - cnt,size)]
+                      | otherwise   -> [(0,back), (front,cnt - front)]
+    syncBuffer (rBuffer r) mask
+
+clearRing :: RingBuffer u -> IO ()
+clearRing r = do
+    writeIORef (rBack r) 0
+    writeIORef (rSize r) 0
+    syncRing r
+
+pushBack :: RingBuffer u -> u -> IO ()
+pushBack r upd = do
+    back <- readIORef $ rBack r
+    writeIORef (rBack r) (mod (back + 1) (ringCapacity r))
+    updateBuffer (rBuffer r) back upd
+    sz <- readIORef (rSize r)
+    when (sz < ringCapacity r) $ writeIORef (rSize r) (sz + 1)
+    syncRing r
+
+updateBack :: RingBuffer u -> u -> IO ()
+updateBack r upd = do
+    back <- readIORef $ rBack r
+    updateBuffer (rBuffer r) back upd