combobuffer (empty) → 0.1

raw patch · 11 files changed

+516/−0 lines, 11 filesdep +basedep +containersdep +template-haskellsetup-changed

Dependencies added: base, containers, template-haskell, vector, vector-space

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• combobuffer.cabal +35/−0
• src/Data/RingBuffer.hs +17/−0
• src/Data/RingBuffer/Chord.hs +50/−0
• src/Data/RingBuffer/Class.hs +58/−0
• src/Data/RingBuffer/ComboBuffer.hs +108/−0
• src/Data/RingBuffer/MapBuffer.hs +53/−0
• src/Data/RingBuffer/SVec.hs +29/−0
• src/Data/RingBuffer/SeqBuffer.hs +66/−0
• src/Data/RingBuffer/TGen.hs +68/−0

@@ -0,0 +1,30 @@+Copyright John W. Lato 2011++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of John W. Lato nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,35 @@+Name:                combobuffer+Version:             0.1+Synopsis:            Various buffer implementations+Description:         Various buffer implementations+Homepage:            https://github.com/JohnLato/combobuffer+License:             BSD3+License-file:        LICENSE+Author:              John W. Lato+Maintainer:          jwlato@gmail.com+Category:            Data+Build-type:          Simple+Cabal-version:       >=1.6++Library+  Hs-Source-Dirs:     src+  Exposed-modules:    Data.RingBuffer+                     ,Data.RingBuffer.Chord+                     ,Data.RingBuffer.Class+                     ,Data.RingBuffer.ComboBuffer+                     ,Data.RingBuffer.MapBuffer+                     ,Data.RingBuffer.SeqBuffer+                     ,Data.RingBuffer.SVec+                     ,Data.RingBuffer.TGen++  Build-depends:      base         >= 3      && < 5+                     ,containers   >= 0.3    && < 0.6+                     ,template-haskell >= 2.6 && < 2.9+                     -- ,type-level   >= 0.2    && < 0.3+                     -- ,tuple        >= 0.2    && < 0.3+                     ,vector       >= 0.5    && < 0.11+                     ,vector-space >= 0.7    && < 0.9+  +source-repository head+  type:                git+  location:            git@github.com:JohnLato/combobuffer.git

@@ -0,0 +1,17 @@+module Data.RingBuffer (+  Initializable (..)+ ,RingBuffer (..)+ ,El+ ,SeqBuffer (..)+ ,ComboBuffer (..)+ ,MapBuffer   (..)+ ,module X+)++where++import Data.RingBuffer.Class+import Data.RingBuffer.ComboBuffer+import Data.RingBuffer.MapBuffer+import Data.RingBuffer.SeqBuffer+import Data.RingBuffer.SVec as X

@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wall #-}+module Data.RingBuffer.Chord+(+  Chord+, emptyChord+, cToVec+)++where++import Prelude hiding (length)+import Data.RingBuffer.Class+import qualified Data.Vector.Unboxed as V+import           Data.Vector.Unboxed (Vector, Unbox)++-- A structure for pushing elements+-- params:+--   partial chunk fill+--   partial chunk+--   full chunk quantity+--   full chunks+data Chord a = Chord !Int [a] !Int [Vector a]+  deriving (Show, Eq, Ord)++-- | an empty chord.+emptyChord :: a -> Chord a+emptyChord _ = Chord 0 [] 0 []++cToVec :: Unbox a => Chord a -> Vector a+cToVec (Chord pf pc _ cs) = V.concat (V.fromListN pf pc : cs)+{-# INLINE cToVec #-}++type instance (El (Chord a)) = a++instance V.Unbox a => RingBuffer (Chord a) where+  {-# INLINE length #-}+  length (Chord pfill _ c _) = 32*c + pfill+  {-# INLINE push #-}+  push   (Chord 31 pc n cs) el =+     let new = V.fromListN 32 (el:pc)+     in  new `seq` Chord 0 [] (n+1) (new:cs)+  push   (Chord pf pc n cs) el =+     Chord (pf+1) (el : pc) n cs+  {-# INLINE (!) #-}+  (Chord pf pc _ cs) ! ix+     | ix <= pf  = pc !! ix+     | otherwise = let (major,minor) = (ix - pf) `divMod` 32+                   in (cs !! major) `V.unsafeIndex` minor

@@ -0,0 +1,58 @@+{-# LANGUAGE TypeFamilies, GADTs #-}++{-# OPTIONS_GHC -Wall #-}+-- | The RingBuffer interface.+--+-- A RingBuffer is a fixed-length buffer that supports lookups anywhere in+-- the structure and pushing new elements onto the front.  When a new value is+-- pushed, the oldest value will be dropped.+--+-- This module provides an implementation based on+-- 'Data.Vector.Unboxed.Vector', with O(1) lookups and O(n) pushes.  Other+-- modules provide implementations with different performance profiles.+module Data.RingBuffer.Class (+  El+ ,RingBuffer (..)+ ,Initializable (..)+)++where++import Prelude hiding (length)+import qualified Data.Vector.Unboxed as V++type family El c :: *++-- | Create a new 'Initializable' with the given value at every position.+-- Essentially a generalized 'Prelude.replicate'+class Initializable c where+  newInit :: El c -> Int -> c++-- | The RingBuffer interface.+--+-- Instances must define 'length', 'push', and '(!)'.  Instances may define+-- 'slice' for better performance.+class RingBuffer c where+  length    :: c -> Int+  push      :: c -> El c -> c+  (!)       :: c -> Int  -> El c+  slice     :: c -> Int  -> Int -> [El c]+  {-# INLINE slice #-}+  slice c start num = [ c ! ix | ix <- [start .. start+num]]+++type instance El (V.Vector el) = el++instance V.Unbox el => Initializable (V.Vector el) where+  {-# INLINE newInit #-}+  newInit = flip V.replicate++instance V.Unbox el => RingBuffer (V.Vector el) where+  {-# INLINE length #-}+  length      = V.length+  {-# INLINE (!) #-}+  (!)         = (V.!)+  {-# INLINE push #-}+  push vec el = V.cons el $ V.unsafeInit vec+  {-# INLINE slice #-}+  slice vec start num = V.toList $ V.slice start num vec

@@ -0,0 +1,108 @@+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wall #-}+-- | Generally the best-performing implementation in this package.+--+-- 'ComboBuffer' supports amortized O(1) push and O(1) length.  lookups at 'ix+-- >= n/2' and 'ix=0' are O(1), while lookups at '0 <= ix < n/2' are no more+-- than O(n).  If you need to do many lookups in the first half, and+-- particularly around n/4, another structure may be a better choice.+module Data.RingBuffer.ComboBuffer (+  ComboBuffer (..)+)++where++import           Prelude hiding (length)++import           Data.RingBuffer.Class+import           Data.RingBuffer.Chord+import qualified Data.Vector.Unboxed as V++data ComboBuffer a =+   CB {-# UNPACK #-} !Int          -- Half Size+      {-# UNPACK #-} !Int          -- buffer position+                     !(V.Vector a) -- newer vector+                     !(V.Vector a) -- older vector+      (Chord a)                    -- updates+ | CBOdd {-# UNPACK #-} !Int          -- Half (Size + 1)+         {-# UNPACK #-} !Int          -- buffer position+                        !(V.Vector a) -- newer vector+                        !(V.Vector a) -- older vector+         (Chord a)                    -- updates+ deriving (Eq, Ord, Show)++type instance El (ComboBuffer a) = a++instance V.Unbox a => Initializable (ComboBuffer a) where+  {-# INLINE newInit #-}+  newInit = newInit'++newInit' :: V.Unbox a => a -> Int -> ComboBuffer a+newInit' el sz+  | sz <= 0 = error "Can't initialize ComboBuffer with size <= 0"+  | sz `rem` 2 == 0 = let half = sz `div` 2+                          iv   = V.replicate half el+                      in  CB half 0 iv iv (emptyChord el)+  | otherwise       = let half = (1+sz) `div` 2+                          iv   = V.replicate half el+                      in  CBOdd half 0 iv iv (emptyChord el)+{-# INLINE newInit' #-}++instance V.Unbox a => RingBuffer (ComboBuffer a) where+  {-# INLINE length #-}+  length (CB sz _ _ _ _)    = 2*sz+  length (CBOdd sz _ _ _ _) = 2*sz-1+  {-# INLINE (!) #-}+  (!) = at+  {-# INLINE push #-}+  push = pushB+  {-# INLINE slice #-}+  slice = sliceB++at :: V.Unbox a => ComboBuffer a -> Int -> a+at (CB sz pos v1 v2 upds) ix+  | ix < 0    = error $ "ComboBuffer: index out of range: " ++ show ix+  | ix < pos  = upds ! ix+  | ix < 2*sz = let ix' = ix - pos in if ix' < sz+                  then v1 `V.unsafeIndex` ix'+                  else v2 `V.unsafeIndex` (ix' - sz)+  | otherwise = error $ "ComboBuffer: index out of range: " ++ show (ix,2*sz)+at (CBOdd sz pos v1 v2 upds) ix+  | ix < 0      = error $ "ComboBuffer: index out of range: " ++ show ix+  | ix < pos    = upds ! ix+  | ix < 2*sz-1 = let ix' = ix - pos in if ix' < sz+                    then v1 `V.unsafeIndex` ix'+                    else v2 `V.unsafeIndex` (ix' - sz)+  | otherwise = error $ "ComboBuffer: index out of range: " ++ show (ix,2*sz-1)+{-# INLINE at #-}++sliceB :: V.Unbox a => ComboBuffer a -> Int -> Int -> [a]+sliceB (CB sz pos v1 v2 upds) start num+  = let ix' = start - pos+        fstTake = sz - (ix'+num)+    in if ix' < sz+         then slice upds start num+              ++ V.toList (V.slice ix' (min 0 fstTake) v1)+              ++ V.toList (V.slice 0 (min 0 (negate fstTake)) v2)+         else V.toList (V.slice (ix'-sz) num v2)+sliceB (CBOdd sz pos v1 v2 upds) start num+  = let ix' = start - pos+        fstTake = sz - (ix'+num)+    in if ix' < sz+         then slice upds start num+              ++ V.toList (V.slice ix' (min 0 fstTake) v1)+              ++ V.toList (V.slice 0 (min 0 (negate fstTake)) v2)+         else V.toList (V.slice (ix'-sz) num v2)+{-# INLINE sliceB #-}++pushB :: V.Unbox a => ComboBuffer a -> a -> ComboBuffer a+pushB (CB sz pos v1 v2 upds) el+  | pos == sz-1 = CB sz 0 (cToVec $ push upds el) v1+                          (emptyChord el)+  | otherwise   = CB sz (pos+1) v1 v2 (push upds el)+pushB (CBOdd sz pos v1 v2 upds) el+  | pos == sz-1 = CBOdd sz 0 (cToVec $ push upds el) v1+                           (emptyChord el)+  | otherwise   = CBOdd sz (pos+1) v1 v2 (push upds el)+{-# INLINE pushB #-}

@@ -0,0 +1,53 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -Wall #-}+-- | A 'RingBuffer' implementation based on IntMaps.  Operations have the same+-- complexity as the underlying IntMap+module Data.RingBuffer.MapBuffer (+  Initializable (..)+ ,RingBuffer (..)+ ,MapBuffer (..)+)++where++import           Prelude hiding (length)++import           Data.RingBuffer.Class+import           Data.IntMap (IntMap)+import qualified Data.IntMap as M++data MapBuffer a = MB {-# UNPACK #-} !Int !(IntMap a) +  deriving (Eq, Show, Ord)++type instance El (MapBuffer el) = el++instance Initializable (MapBuffer el) where+  {-# INLINE newInit #-}+  newInit el sz = MB 0 $ M.fromDistinctAscList $ map (,el) [0..sz-1]++instance RingBuffer (MapBuffer el) where+  {-# INLINE length #-}+  length (MB _ vec) = M.size vec+  {-# INLINE (!) #-}+  (MB pos vec) ! ix = vec M.! ((pos-ix-1) `mod` M.size vec)+  {-# INLINE push #-}+  push = pushE+  {-# INLINE slice #-}+  slice = sliceB++pushE :: MapBuffer a -> a -> MapBuffer a+pushE (MB pos vec) el = +  let newPos = if pos == M.size vec - 1 then 0 else pos + 1+      vec' = M.insert pos el vec+  in  MB newPos vec'+{-# INLINE pushE #-}++sliceB :: MapBuffer a -> Int -> Int -> [a]+sliceB (MB pos vec) start num = -- V.toList $ V.slice (pos+start) num vec+  let ix1 = pos+start+      top = snd $ M.split (ix1-1) vec+  in  map snd . M.toAscList . fst $ M.split (ix1+num) top+{-# INLINE sliceB #-}

@@ -0,0 +1,29 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveFoldable #-}++{-# OPTIONS_GHC -funbox-strict-fields #-}++-- | Strict vectors of doubles to length == 30+module Data.RingBuffer.SVec++where++import Prelude hiding (length)+import Data.RingBuffer.Class+import Data.RingBuffer.TGen+import Language.Haskell.TH (Type(..),mkName, TyVarBndr(..))++import Data.Foldable++$(mkVecFromTo 1 30 (ConT ''Double) [] "")++-- | Generate a 32-element polymorphic vector, maybe I should just use+-- Data.Vector?+$(mkVecFromTo 32 32 (VarT (mkName "a")) [PlainTV (mkName "a")] "Vec")++deriving instance Show a => Show (TVec32 a)+deriving instance Eq a => Eq (TVec32 a)+deriving instance Ord a => Ord (TVec32 a)+deriving instance Foldable (TVec32)

@@ -0,0 +1,66 @@+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wall #-}+-- | A 'RingBuffer' based on 'Data.Sequence.Seq'.  Asymptotic behavior is quite+-- good in all cases, but constant factors are very high.+module Data.RingBuffer.SeqBuffer (+  SeqBuffer+ ,RingBuffer (..)+ ,new+)++where++import           Prelude hiding (length, (!!))+import           Data.RingBuffer.Class++import qualified Data.Sequence as S+import           Data.Foldable++newtype SeqBuffer a = RB (S.Seq a) deriving (Eq, Ord, Show)++type instance El (SeqBuffer a) = a++instance Initializable (SeqBuffer a) where+  {-# INLINE newInit #-}+  newInit = newInit'++instance RingBuffer (SeqBuffer a) where+  {-# INLINE length #-}+  length  = length'+  {-# INLINE push #-}+  push    = push'+  {-# INLINE (!) #-}+  (!)     = (!!)+  {-# INLINE slice #-}+  slice (RB sq) start num = toList . S.take num $ S.drop start sq++-- | Create a new SeqBuffer, initialized to all 0's, of the given size+new :: (Num a) => Int -> SeqBuffer a+new = newInit' 0+{-# INLINE new #-}++-- | Create a new SeqBuffer from a given initial value+newInit' :: a -> Int -> SeqBuffer a+newInit' _ sz | sz <= 0 = error "can't make empty ringbuffer"+newInit' i sz           = RB (S.replicate sz i)+{-# INLINE newInit' #-}++-- | Get the total size of a SeqBuffer.+length' :: SeqBuffer a -> Int+length' (RB vec) = S.length vec+{-# INLINE length' #-}++-- | Look up a value in a SeqBuffer.+(!!) :: SeqBuffer a -> Int -> a+(!!) (RB vec) = S.index vec+{-# INLINE (!!) #-}++-- | Push a new value into a SeqBuffer.  The following will hold:+--     NewSeqBuffer ! 0 === added element+--     NewSeqBuffer ! 1 === OldSeqBuffer ! 0+push' :: SeqBuffer a -> a -> SeqBuffer a+push' (RB vec) el   = case S.viewr vec of+  v' S.:> _ -> RB $ el S.<| v'+  _         -> error "internal error"+{-# INLINE push' #-}

@@ -0,0 +1,68 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-- | Template Haskell splices to create  constant-sized vectors and RingBuffer+-- instances for them+module Data.RingBuffer.TGen (+  mkVecFromTo+ ,mkVec+)++where++import Prelude hiding (length)+import Data.RingBuffer.Class++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Control.Applicative+import Control.Monad++mkVecFromTo start stop elname binders prefix =+  concat <$> mapM (mkVec elname binders prefix) [start .. stop]++mkVec elname binders prefix sz = do+  let nm = mkName $ 'T':prefix ++ show sz+  let tname = case binders of+        []   -> ConT nm+        [PlainTV b1] -> AppT (ConT nm) (VarT b1)+        _    -> error "can't handle types with more than 1 type variable, or non-* kinded types"+  d1 <- decTN sz nm elname binders+  d2 <- mkElInst tname elname+  d3 <- mkInitInst sz nm (return tname)+  d4 <- mkRbInst sz nm (return tname)+  return $ concat [d1,d2,d3,d4]++decTN sz nm elname binders =+  let fields = replicate sz (IsStrict, elname)+  in return [DataD [] nm binders [NormalC nm fields] []]++mkElInst tname elname = return [TySynInstD ''El [tname] (elname) ]++mkInitInst vsz nm tname = let nmStr = show nm in [d| instance Initializable $(tname) where {-# INLINE newInit #-}; newInit el sz | sz >= 0 && sz <= vsz = $(appsE $ conE nm:replicate vsz [| el |]) ; newInit el sz = error ("cannot initialize " ++ nmStr ++ " with size: " ++ show sz) |]++mkRbInst vsz nm tname = [d| instance RingBuffer $(tname) where {-# INLINE length #-}; length = const vsz; {-# INLINE (!) #-}; (!) = $(mkLookup vsz nm); {-# INLINE push #-}; push = $(mkPush vsz nm) |]++mkLookup vsz nm = do+  nms <- mapM (newName . ('v':) . show) [1 .. vsz]+  ixNm <- newName "ix"+  let lhs1 = conP nm (map varP nms)+      lhs2 = varP ixNm+      matches = map (\ix -> match (litP $ integerL (fromIntegral ix)) +                                (normalB $ varE (nms !! ix) )+                                [] )+                    [0..vsz-1]+                ++ [match (varP (mkName "ix"))+                          (normalB [| error ("TGen: index out of bounds: " ++ show $(varE $ mkName "ix")) |])+                          [] ]+      rhs  = caseE (varE ixNm) matches+  lamE [lhs1,lhs2] rhs++mkPush vsz nm = do+  nms <- mapM (newName . ('v':) . show) [1 .. vsz]+  elNm <- newName "el"+  let lhs1 = conP nm (map varP nms)+      lhs2 = varP elNm+      rhs  = appsE $ conE nm : varE elNm : map varE (init nms)+  lamE [lhs1, lhs2] rhs