circular (empty) → 0.1.0

raw patch · 8 files changed

+505/−0 lines, 8 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, circular, hspec, hspec-discover, quickcheck-instances, vector

Files

ChangeLog.md +6/−0
LICENSE +30/−0
README.md +25/−0
Setup.hs +2/−0
circular.cabal +60/−0
src/Data/Stack/Circular.hs +261/−0
test/Data/Stack/CircularSpec.hs +120/−0
test/Spec.hs +1/−0

+ ChangeLog.md view

@@ -0,0 +1,6 @@++# Changelog for circular+++## Unreleased changes+

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Dominik Schrempf (c) 2020++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 Dominik Schrempf 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.

+ README.md view

@@ -0,0 +1,25 @@++# Circular++<p align="center"><img src="https://travis-ci.org/dschrempf/circular.svg?branch=master"/></p>++Circular fixed-sized stacks.++Circular stacks with fxed maximum size are just normal vectors with a+pointer to the last element. They are useful because++-   memory usage is constant+-   they are fast, especially when summary statistics need to be+    computed across the stack+-   they can be saved, and restored using JSON format++When the stack is full, new elements pushed on the stack replace the oldest+(deepest) elements on the stack. Complex circular behavior can arise when pushes+and pops are mixed. QuickCheck and unit tests with HSpec give promising results+&#x2014; have a look yourself.++I use them, for example, as the data type for traces of Markov chains.++`Circular` is actively developed and functions may be removed, renamed, or+changed. New ideas are welcome!+

+ Setup.hs view

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

+ circular.cabal view

@@ -0,0 +1,60 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.2.+--+-- see: https://github.com/sol/hpack++name:           circular+version:        0.1.0+synopsis:       Circular fixed-sized mutable vectors+description:    Please see the README on GitHub at <https://github.com/dschrempf/circular#readme>+category:       Math, Data Structures+homepage:       https://github.com/dschrempf/circular#readme+bug-reports:    https://github.com/dschrempf/circular/issues+author:         Dominik Schrempf+maintainer:     dominik.schrempf@gmail.com+copyright:      Dominik Schrempf (2020)+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/dschrempf/circular++library+  exposed-modules:+      Data.Stack.Circular+  other-modules:+      Paths_circular+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      aeson+    , base >=4.7 && <5+    , vector+  default-language: Haskell2010++test-suite circular-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Data.Stack.CircularSpec+      Paths_circular+  hs-source-dirs:+      test+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , aeson+    , base >=4.7 && <5+    , circular+    , hspec+    , hspec-discover+    , quickcheck-instances+    , vector+  default-language: Haskell2010

+ src/Data/Stack/Circular.hs view

@@ -0,0 +1,261 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      :  Data.Stack.Circular+-- Description :  Circular stacks of fixed size+-- Copyright   :  (c) Dominik Schrempf, 2020+-- License     :  GPL-3.0-or-later+--+-- Maintainer  :  dominik.schrempf@gmail.com+-- Stability   :  unstable+-- Portability :  portable+--+-- Creation date: Thu Jun 18 10:00:28 2020.+module Data.Stack.Circular+  ( -- * Boxed circular stacks+    CStack (..),++    -- * Construction+    empty,++    -- * Conversion+    toVector,+    toVectorN,+    fromVector,++    -- * Accessors+    get,+    pop,+    push,+    unsafePush,++    -- * Queries+    isFull,++    -- * Folding+    --+    -- Here all fold functions should be provided, but I am too lazy. Instead,+    -- let's just provide some optimized functions to compute summary statistics+    -- across all values on the stack.+    --+    -- For reasons of efficiency, __commutativity__ of the combining function is+    -- __assumed__ for fold-like functions provided in this section! That is,+    -- the order of elements of the stack must not matter.+    foldl1',+    sum,+    mean,+    product,+  )+where++import Control.Monad.ST+import Data.Aeson+import Data.Aeson.Types+import qualified Data.Vector.Generic as V+import Data.Vector.Generic (Vector)+import qualified Data.Vector.Generic.Mutable as M+import Prelude hiding (product, sum)++-- | Circular stacks with fxed maximum size are just normal vectors with a+-- pointer to the last element.+--+-- Construction of 'CStack's is done with 'empty' and subsequent 'push'es, or+-- the provided type conversion functions so that the index and bounds are+-- updated and checked consistently. The data constructor 'CStack' is exported+-- only to enable creation of orphan instances such as Arbitrary (QuickCheck).+--+-- When denoting the efficiency of the functions @m@ refers to the current size+-- of the stack, and @n@ to the maximum size.+data CStack v a = CStack+  { stack :: v a,+    index :: !Int,+    curSize :: !Int+  }++instance (Eq (v a), Vector v a) => Eq (CStack v a) where+  (CStack v1 i1 m1) == (CStack v2 i2 m2) = (v1 == v2) && (i1 == i2) && (m1 == m2)++instance (Show (v a), Vector v a) => Show (CStack v a) where+  show c@(CStack _ i m) = "CStack {" ++ show (toVector c) ++ ", " ++ show i ++ ", " ++ show m ++ "}"++-- | We have @c /= FromJSON $ ToJSON c@, but the elements on the stack and their+-- order are correctly saved and restored.+instance (ToJSON a, ToJSON (v a), Vector v a) => ToJSON (CStack v a) where+  toJSON c = object ["stack" .= toVector c, "maxSize" .= n]+    where+      n = V.length $ stack c+  toEncoding c = pairs ("stack" .= toVector c <> "maxSize" .= n)+    where+      n = V.length $ stack c++instance (FromJSON a, FromJSON (v a), Vector v a) => FromJSON (CStack v a) where+  parseJSON = withObject "CStack" fromObject++fromObject :: forall v a. (FromJSON (v a), Vector v a) => Object -> Parser (CStack v a)+fromObject o = do+  v <- o .: "stack" :: Parser (v a)+  n <- o .: "maxSize" :: Parser Int+  let c = empty n+  pure $ V.foldr' unsafePush c v++-- Calculate the start index of the stack.+--+-- (startIndex + m - 1) `mod` n = i+startIndex :: Int -> Int -> Int -> Int+startIndex i m n+  | m == 0 = error "startIndex: empty stack"+  | m <= i + 1 = i + 1 - m+  | otherwise = i + 1 - m + n++-- | A circular stack without an element but of a given maximum size. At this+-- state, it is not very useful :). O(n).+empty :: Vector v a => Int -> CStack v a+empty n+  | n <= 0 = error "empty: maximum size must be 1 or larger"+  | otherwise = CStack (V.create $ M.unsafeNew n) 0 0++-- | Convert a circular stack to a vector. The first element of the returned+-- vector is the deepest (oldest) element of the stack, the last element of the+-- returned vector is the current (newest) element of the stack.+--+-- This is a relatively expensive operation. O(m).+toVector :: Vector v a => CStack v a -> v a+toVector (CStack v i m)+  | m == 0 = V.empty+  | i' + m <= n = V.unsafeSlice i' m v+  | otherwise = V.unsafeDrop i' v V.++ V.unsafeTake (i + 1) v+  where+    n = V.length v+    i' = startIndex i m n++-- | Convert the last N elements of a circular stack to a vector. The first+-- element of the returned vector is the deepest (oldest) element of the stack,+-- the last element of the returned vector is the current (newest) element of+-- the stack.+--+-- The size of the stack must be larger than N.+--+-- This is a relatively expensive operation. O(N).+toVectorN :: Vector v a => Int -> CStack v a -> v a+toVectorN k (CStack v i m)+  | k < 0 = error "toVectorN: negative n"+  | k > m = error "toVectorN: stack too small"+  | k == 0 = V.empty+  | i' + k <= n = V.unsafeSlice i' k v+  | otherwise = V.unsafeDrop i' v V.++ V.unsafeTake (i + 1) v+  where+    n = V.length v+    i' = startIndex i k n++-- | Convert a vector to a circular stack. The first element of the vector is+-- the deepest (oldest) element of the stack, the last element of the vector is+-- the current (newest) element of the stack. O(n).+--+-- The vector must be non-empty.+fromVector :: Vector v a => v a -> CStack v a+fromVector v+  | V.null v = error "fromVector: empty vector"+  | otherwise = CStack v (n - 1) n+  where+    n = V.length v++-- | Get the last element without changing the stack. O(1).+get :: Vector v a => CStack v a -> a+get (CStack v i _) = V.unsafeIndex v i++-- Select the previous element without changing the stack.+previous :: Vector v a => CStack v a -> CStack v a+previous (CStack v i m)+  | m == 0 = error "previous: empty stack"+  | i == 0 = CStack v (n - 1) (m - 1)+  | otherwise = CStack v (i - 1) (m - 1)+  where+    n = V.length v++-- | Get the last element and remove it from the stack. O(1).+--+-- The stack must be non-empty.+pop :: Vector v a => CStack v a -> (a, CStack v a)+pop c = (get c, previous c)++-- Replace an element in a vector.+set :: Vector v a => Int -> a -> v a -> v a+set i x = V.modify (\v -> M.write v i x)+{-# INLINE set #-}++-- Replace the last element.+put :: Vector v a => a -> CStack v a -> CStack v a+put x (CStack v i m) = CStack (set i x v) i m++-- Select the next element without changing the stack.+next :: Vector v a => CStack v a -> CStack v a+next (CStack v i m)+  | i == (n - 1) = CStack v 0 (min (m + 1) n)+  | otherwise = CStack v (i + 1) (min (m + 1) n)+  where+    n = V.length v++-- | Push an element on the stack. O(n).+push :: Vector v a => a -> CStack v a -> CStack v a+push x c = put x $ next c++unsafeSet :: Vector v a => Int -> a -> v a -> v a+unsafeSet i x v = runST $ do+  mv <- V.unsafeThaw v+  M.unsafeWrite mv i x+  V.unsafeFreeze mv++-- Replace the last element. O(1).+unsafePut :: Vector v a => a -> CStack v a -> CStack v a+unsafePut x (CStack v i m) = CStack (unsafeSet i x v) i m++-- | Push an element on the stack. O(1).+--+-- Be careful; the internal vector is mutated! The immutable circular stack may+-- not be used after this operation.+unsafePush :: Vector v a => a -> CStack v a -> CStack v a+unsafePush x c = unsafePut x $ next c++-- | Check if the stack is full.+isFull :: Vector v a => CStack v a -> Bool+isFull (CStack v _ m) = V.length v == m++-- | Compute summary statistics of the elements on the stack using a custom+-- commutative `mappend` function.+foldl1' :: Vector v a => (a -> a -> a) -> CStack v a -> a+foldl1' f (CStack v i m)+  | m == n = V.foldl1' f v+  | i' + m <= n = V.foldl1' f $ V.unsafeSlice i' m v+  | otherwise = f (V.foldl1' f (V.unsafeDrop i' v)) (V.foldl1' f (V.unsafeTake (i + 1) v))+  where+    n = V.length v+    i' = startIndex i m n++-- | Compute the sum of the elements on the stack.+sum :: (Num a, Vector v a) => CStack v a -> a+sum (CStack v i m)+  | m == n = V.sum v+  | i' + m <= n = V.sum $ V.unsafeSlice i' m v+  | otherwise = V.sum (V.unsafeDrop i' v) + V.sum (V.unsafeTake (i + 1) v)+  where+    n = V.length v+    i' = startIndex i m n++-- | Compute the mean of the elements on the stack.+mean :: (Real a, Vector v a, Fractional b) => CStack v a -> b+mean c = realToFrac (sum c) / fromIntegral (curSize c)++-- | Compute the product of the elements on the stack.+--+-- For reasons of efficiency, commutativity of the combining function is+-- assumed. That is, the order of elements of the stack must not matter.+product :: (Num a, Vector v a) => CStack v a -> a+product (CStack v i m)+  | m == n = V.product v+  | i' + m <= n = V.product $ V.unsafeSlice i' m v+  | otherwise = V.product (V.unsafeDrop i' v) * V.product (V.unsafeTake (i + 1) v)+  where+    n = V.length v+    i' = startIndex i m n

+ test/Data/Stack/CircularSpec.hs view

@@ -0,0 +1,120 @@+{-# LANGUAGE FlexibleInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+--   Module      :  Data.Stack.CircularSpec+--   Description :  Unit tests for Data.Stack.Circular+--   Copyright   :  (c) Dominik Schrempf, 2020+--   License     :  GPL-3.0-or-later+--+--   Maintainer  :  dominik.schrempf@gmail.com+--   Stability   :  unstable+--   Portability :  portable+--+-- Creation date: Thu Jun 18 10:21:28 2020.+module Data.Stack.CircularSpec+  ( spec,+  )+where++import Control.Exception+import Data.Aeson+import Data.Stack.Circular as C+import Data.Vector (Vector)+import qualified Data.Vector as V+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck hiding (Success, Result)+import Test.QuickCheck.Instances.Vector ()+import Prelude hiding (sum, product)++instance Arbitrary (CStack Vector Int) where+  arbitrary = do+    s <- getSize+    n <- choose (1, s+1)+    v <- V.fromList <$> vector n+    i <- choose (0, n-1)+    m <- choose (1, n)+    return $ CStack v i m++se :: CStack Vector Int+se = empty 10++ss :: CStack Vector Int+ss = push 13 se++prop_from_to_id :: Vector Int -> Bool+prop_from_to_id v+  | V.length v == 0 = True+  | otherwise = toVector (fromVector v) == v++prop_pop :: Vector Int -> Bool+prop_pop v+  | V.length v == 0 = True+  | otherwise = toVector (snd $ pop $ fromVector v) == V.init v++prop_push_pop :: Int -> Vector Int -> Bool+prop_push_pop x v+  | V.length v == 0 = True+  | otherwise = toVector (snd $ pop $ push x $ fromVector v) == V.tail v++prop_push :: Int -> Vector Int -> Bool+prop_push x v+  | V.length v == 0 = True+  | otherwise = toVector (push x $ fromVector v) == V.tail v V.++ V.singleton x++prop_many_pushes :: [Int] -> Vector Int -> Bool+prop_many_pushes xs v+  | V.length v == 0 = True+  | length xs <= V.length v = True+  | otherwise =+    toVector (foldr push (fromVector v) xs)+      == V.fromList (reverse $ take (V.length v) xs)++prop_length :: CStack Vector Int -> Bool+prop_length c = V.length (toVector c) == curSize c++jsonId :: CStack Vector Int -> Result (CStack Vector Int)+jsonId c = fromJSON $ toJSON c++prop_json_sum :: CStack Vector Int -> Bool+prop_json_sum c = (sum <$> jsonId c) == Success (sum c)++prop_json_product :: CStack Vector Int -> Bool+prop_json_product c = (product <$> jsonId c) == Success (product c)++-- Check current size and max size.+prop_json_misc :: CStack Vector Int -> Bool+prop_json_misc c = ((curSize <$> jsonId c) == Success (curSize c)) &&+                   ((V.length . stack <$> jsonId c) == Success (V.length $ stack c))++spec :: Spec+spec = do+  describe "construction" $ it "doesn't choke on weird inputs" $ do+    print ss+    toVector se `shouldBe` V.empty+    toVector (snd $ pop ss) `shouldBe` V.empty++  describe "conversion identities" $ do+    it "correctly converts partly filled stacks" $+      toVector ss `shouldBe` V.singleton 13+    prop "toVector . fromVector is identity" (prop_from_to_id :: Vector Int -> Bool)++  describe "conversion failure" $+    it "fails to convert empty vectors" $+      evaluate (fromVector V.empty) `shouldThrow` anyErrorCall++  describe "properties" $ do+    prop "pop" prop_pop+    prop "push" prop_push+    prop "push pop" prop_push_pop+    prop "many pushed" prop_many_pushes+    prop "length" prop_length+    prop "json sum" prop_json_sum+    prop "json product" prop_json_product+    prop "json misc" prop_json_misc++  describe "laziness" $+    it "should not conflict with intuition" $+    toVector ss `shouldNotBe` toVector (push 10 ss)

+ test/Spec.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}