diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/combobuffer.cabal b/combobuffer.cabal new file mode 100644 --- /dev/null +++ b/combobuffer.cabal @@ -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 diff --git a/src/Data/RingBuffer.hs b/src/Data/RingBuffer.hs new file mode 100644 --- /dev/null +++ b/src/Data/RingBuffer.hs @@ -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 diff --git a/src/Data/RingBuffer/Chord.hs b/src/Data/RingBuffer/Chord.hs new file mode 100644 --- /dev/null +++ b/src/Data/RingBuffer/Chord.hs @@ -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 diff --git a/src/Data/RingBuffer/Class.hs b/src/Data/RingBuffer/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/RingBuffer/Class.hs @@ -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 diff --git a/src/Data/RingBuffer/ComboBuffer.hs b/src/Data/RingBuffer/ComboBuffer.hs new file mode 100644 --- /dev/null +++ b/src/Data/RingBuffer/ComboBuffer.hs @@ -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 #-} diff --git a/src/Data/RingBuffer/MapBuffer.hs b/src/Data/RingBuffer/MapBuffer.hs new file mode 100644 --- /dev/null +++ b/src/Data/RingBuffer/MapBuffer.hs @@ -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 #-} diff --git a/src/Data/RingBuffer/SVec.hs b/src/Data/RingBuffer/SVec.hs new file mode 100644 --- /dev/null +++ b/src/Data/RingBuffer/SVec.hs @@ -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) diff --git a/src/Data/RingBuffer/SeqBuffer.hs b/src/Data/RingBuffer/SeqBuffer.hs new file mode 100644 --- /dev/null +++ b/src/Data/RingBuffer/SeqBuffer.hs @@ -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' #-} diff --git a/src/Data/RingBuffer/TGen.hs b/src/Data/RingBuffer/TGen.hs new file mode 100644 --- /dev/null +++ b/src/Data/RingBuffer/TGen.hs @@ -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