packages feed

compact-sequences (empty) → 0.1.0.0

raw patch · 11 files changed

+966/−0 lines, 11 filesdep +basedep +containersdep +primitivesetup-changed

Dependencies added: base, containers, primitive, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for compact-sequences++## 0.1.0.0 -- 2020-08-11++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020, David Feuer++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 David Feuer 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ compact-sequences.cabal view
@@ -0,0 +1,48 @@+cabal-version:       2.2++-- Initial package description 'compact-sequences.cabal' generated by+-- 'cabal init'.+-- For further documentation, see http://haskell.org/cabal/users-guide/++name:                compact-sequences+version:             0.1.0.0+synopsis: Stacks and queues with compact representations.+description:+  Stacks and queues that take n + O(log n) space at the cost of+  having amortized O(log n) time complexity for basic operations.+bug-reports: https://github.com/treeowl/compact-sequences/issues+homepage: https://github.com/treeowl/compact-sequences/+license:             BSD-3-Clause+license-file:        LICENSE+author:              David Feuer+maintainer:          David.Feuer@gmail.com+copyright: 2020 David Feuer+category:            Data+extra-source-files:  CHANGELOG.md++source-repository head+    type:     git+    location: http://github.com/treeowl/compact-sequences.git++library+  exposed-modules: Data.CompactSequence.Stack.Simple+                 , Data.CompactSequence.Stack.Internal+                 , Data.CompactSequence.Queue.Simple+                 , Data.CompactSequence.Queue.Internal+                 , Data.CompactSequence.Internal.Array+                 , Data.CompactSequence.Internal.Array.Safe+  -- other-modules:+  -- other-extensions:+  build-depends:       base >=4.10.0.0 && < 5.0+                     , primitive+                     , containers+                     , transformers+  hs-source-dirs:      src+  default-language:    Haskell2010++test-suite compact-sequences-test+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             MyLibTest.hs+  build-depends:       base >=4.10.0.0
+ src/Data/CompactSequence/Internal/Array.hs view
@@ -0,0 +1,112 @@+{-# language DataKinds #-}+{-# language TypeOperators #-}+{-# language KindSignatures #-}+{-# language BangPatterns #-}+{-# language RoleAnnotations #-}+{-# language MagicHash #-}+{-# language UnboxedTuples #-}+{-# language NoStarIsType #-}+{-# language RankNTypes #-}+{-# language DeriveTraversable #-}+{-# language Unsafe #-}++module Data.CompactSequence.Internal.Array where+import Data.Primitive.SmallArray+import Control.Monad.ST.Strict++-- fixed-vector+-- unpacked-containers+-- contiguous++data Mult = Twice Mult | Mul1++newtype Array (n :: Mult) a = Array (SmallArray a)+  deriving (Functor, Foldable, Traversable)+type role Array nominal representational++newtype Size (n :: Mult) = Size Int+type role Size nominal++getSize :: Size n -> Int+getSize (Size n) = n++--halve :: Size (Twice m) -> Size m+--halve (Size n) = Size (n `quot` 2)++one :: Size Mul1+one = Size 1++twice :: Size n -> Size (Twice n)+twice (Size n) = Size (2*n)++singleton :: a -> Array Mul1 a+singleton x = Array (pure x)++-- | Unsafely convert a 'SmallArray' of size @n@+-- to an @'Array' n@. This is genuinely unsafe: if+-- @n@ is greater than the true array size, then+-- some operation will eventually violate memory safety.+unsafeSmallArrayToArray :: SmallArray a -> Array n a+unsafeSmallArrayToArray = Array++arrayToSmallArray :: Array n a -> SmallArray a+arrayToSmallArray (Array sa) = sa++getSingleton# :: Array Mul1 a -> (# a #)+getSingleton# (Array sa) = indexSmallArray## sa 0++getSingletonA :: Applicative f => Array Mul1 a -> f a+getSingletonA (Array sa)+  | (# a #) <- indexSmallArray## sa 0+  = pure a++splitArray :: Size n -> Array (Twice n) a -> (Array n a, Array n a)+splitArray (Size len) (Array sa1) = (Array sa2, Array sa3)+  where+    !sa2 = cloneSmallArray sa1 0 len+    !sa3 = cloneSmallArray sa1 len len++-- | Append two arrays of the same size. We take the size+-- of the argument arrays so we can build the result array+-- before loading the first argument array into cache. Is+-- this the right approach? Not sure. We *certainly* don't+-- want to just use `<>`, because +append :: Size n -> Array n a -> Array n a -> Array (Twice n) a+append (Size n) (Array xs) (Array ys) = Array $+    createSmallArray (2*n)+      (error "Data.CompactSequence.Internal.Array.append: Internal error")+      $ \sma -> copySmallArray sma 0 xs 0 n+        *> copySmallArray sma n ys 0 n++-- Shamelessly stolen from primitive.+createSmallArray+  :: Int+  -> a+  -> (forall s. SmallMutableArray s a -> ST s ())+  -> SmallArray a+createSmallArray n x f = runSmallArray $ do+  mary <- newSmallArray n x+  f mary+  pure mary++arraySplitListN :: Size n -> [a] -> (Array n a, [a])+arraySplitListN (Size n) xs+  | (sa, xs') <- smallArraySplitListN n xs+  = (Array sa, xs')++smallArraySplitListN :: Int -> [a] -> (SmallArray a, [a])+smallArraySplitListN n l = runST $ do+  sma <- newSmallArray n (error "smallArraySplitListN: uninitialized")+  let go !ix [] = if ix == n+        then do+          sa <- unsafeFreezeSmallArray sma+          pure (sa, [])+        else error "smallArraySplitListN: list length less than specified size"+      go !ix xss@(x : xs) = if ix < n+        then do+          writeSmallArray sma ix x+          go (ix+1) xs+        else do+          sa <- unsafeFreezeSmallArray sma+          pure (sa, xss)+  go 0 l
+ src/Data/CompactSequence/Internal/Array/Safe.hs view
@@ -0,0 +1,19 @@+{-# language MagicHash #-}+{-# language Trustworthy #-}++module Data.CompactSequence.Internal.Array.Safe+  ( Mult (..)+  , Array+  , Size+  , getSize+  , one+  , twice+  , singleton+  , getSingleton#+  , getSingletonA+  , arrayToSmallArray+  , splitArray+  , append+  , arraySplitListN+  ) where+import Data.CompactSequence.Internal.Array
+ src/Data/CompactSequence/Queue/Internal.hs view
@@ -0,0 +1,228 @@+{-# language CPP #-}+{-# language BangPatterns, ScopedTypeVariables, UnboxedTuples, MagicHash #-}+{-# language DeriveTraversable, StandaloneDeriving #-}+{-# language DataKinds #-}+-- {-# OPTIONS_GHC -Wall #-}++module Data.CompactSequence.Queue.Internal where+--import Data.Primitive.SmallArray (SmallArray)+--import qualified Data.Primitive.SmallArray as A+import qualified Data.CompactSequence.Internal.Array as A+import Data.CompactSequence.Internal.Array (Array, Size, Mult (..))+import qualified Data.Foldable as F+import Data.Function (on)++data FD n a+  = FD1 !(Array n a)+  | FD2 !(Array n a) !(Array n a)+  | FD3 !(Array n a) !(Array n a) !(Array n a)+  deriving (Functor, Foldable, Traversable)+-- FD2 and FD3 are safe; FD1 is dangerous.++data RD n a+  = RD0+  | RD1 !(Array n a)+  | RD2 !(Array n a) !(Array n a)+  deriving (Functor, Foldable, Traversable)+-- RD0 and RD1 are safe; RD2 is dangerous.++data Queue n a+  = Empty+  | Node !(FD n a) (Queue ('Twice n) a) !(RD n a)+  deriving (Functor, Traversable)+-- An Empty node is safe.+-- A Node node is safe if both its digits are safe. We require that the child queue of an unsafe+-- node be in WHNF, and allow no debits on it.+--+--+-- To calculate the debit allowance of the child queue of a *safe* node:+--+-- To each ancestor of the node, assign 1 if the node is safe and 0 if it is+-- unsafe. Calculate the value of the binary number so obtained. For example,+-- given+--+-- Safe+-- Safe+-- Dangerous+-- Safe+-- Node+--+-- the *safety value* above Node, sv(Node), is 1*1+1*2+0*4+1*8 = 11+--+-- We allow the child queue of a safe node four times its safety value (for some value of four).++data ViewA n a+  = EmptyA+  | ConsA !(Array n a) (Queue n a)++data ViewA2 n a+  = EmptyA2+  | ConsA2 !(Array n a) !(Array n a) (Queue n a)++singletonA :: Array n a -> Queue n a+singletonA sa = Node (FD1 sa) Empty RD0++viewA :: Size n -> Queue n a -> ViewA n a+-- Non-cascading+viewA !_ Empty = EmptyA+viewA !_ (Node (FD3 sa1 sa2 sa3) m sf) = ConsA sa1 $ Node (FD2 sa2 sa3) m sf+viewA !_ (Node (FD2 sa1 sa2) m sf) = ConsA sa1 $ m `seq` Node (FD1 sa2) m sf+-- Potentially cascading+viewA !n (Node (FD1 sa1) m (RD2 sa2 sa3)) = ConsA sa1 $+  case shiftA (A.twice n) m (A.append n sa2 sa3) of+    ShiftedA sam m'+      | (sam1, sam2) <- A.splitArray n sam+      -> Node (FD2 sam1 sam2) m' RD0+viewA !n (Node (FD1 sa1) m sf) = ConsA sa1 $+  case viewA (A.twice n) m of+    EmptyA -> case sf of+      RD2 sa2 sa3 -> Node (FD2 sa2 sa3) Empty RD0+      RD1 sa2 -> singletonA sa2+      RD0 -> Empty+    ConsA sam m'+      | (sam1, sam2) <- A.splitArray n sam+      -> Node (FD2 sam1 sam2) m' sf++{-+viewA2 :: Size n -> Queue n a -> ViewA2 n a+viewA2 n q = case viewA n q of+  EmptyA -> EmptyA2+  ConsA sa q'+    | (sa1, sa2) <- A.splitArray n sa+    -> ConsA2 sa1 sa2 q'+-}++empty :: Queue n a+empty = Empty+++{-+We have some number of unsafe nodes followed by a safe node. Any operation that cascades+will turn any node it passes into a safe one. Let's first see how debit allowances change.+Initially, the prefix contributes no debit allowance. If the last node that changes was+a safe one and it becomes unsafe, that reduces the debit allowance below it. All but+a logarithmic amount of that reduction is offset by the changes from unsafe to safe+nodes above.++For each unsafe node, we may perform `s` splitting work and perform or suspend+`s` appending work. For purposes of amortized analysis, we can pretend that we+perform all of these eagerly. +-}+++snocA :: Size n -> Queue n a -> Array n a -> Queue n a+snocA !_ Empty sa = Node (FD1 sa) empty RD0+snocA !_ (Node pr m RD0) sa = Node pr m (RD1 sa)+snocA !_ (Node pr m (RD1 sa1)) sa2 = m `seq` Node pr m (RD2 sa1 sa2)+snocA !n (Node (FD1 sa0) m (RD2 sa1 sa2)) sa3+  | ShiftedA sam m' <- shiftA (A.twice n) m (A.append n sa1 sa2)+  , (sam1, sam2) <- A.splitArray n sam+  = Node (FD3 sa0 sam1 sam2) m' (RD1 sa3)+snocA !n (Node pr m (RD2 sa1 sa2)) sa3+  = Node pr (snocA (A.twice n) m (A.append n sa1 sa2)) (RD1 sa3)++-- | Uncons from a node and snoc onto it. Ensure that if the operation is+-- expensive then it leaves the node in a safe configuration. Why do we need+-- this? Suppose we have+--+-- Two m Two+--+-- If we snoc onto this, the operation cascades, and we get+--+-- Two m Zero+--+-- Then when we view, we get+--+-- One m Zero+--+-- which is not safe.+--+-- Instead, we need to view first, getting+--+-- One m Two+--+-- immediately, then snoc on, cascading and getting+--+-- Three m Zero+--+-- which is safe.+--+-- If instead we have+--+-- One m One+--+-- we have to do the opposite: snoc then view. We might as well+-- just write a dedicated shifting operation.+shiftA :: Size n -> Queue n a -> Array n a -> ShiftedA n a+-- Non-cascading cases+shiftA !_ Empty sa = ShiftedA sa Empty+shiftA !_ (Node (FD2 sa1 sa2) m RD0) sa3+  = ShiftedA sa1 $ m `seq` Node (FD1 sa2) m (RD1 sa3)+shiftA !_ (Node (FD2 sa1 sa2) m (RD1 sa3)) sa4+  = ShiftedA sa1 $ m `seq` Node (FD1 sa2) m (RD2 sa3 sa4)+shiftA !_ (Node (FD3 sa1 sa2 sa3) m RD0) sa4+  = ShiftedA sa1 $ Node (FD2 sa2 sa3) m (RD1 sa4)+shiftA !_ (Node (FD3 sa1 sa2 sa3) m (RD1 sa4)) sa5+  = ShiftedA sa1 $ m `seq` Node (FD2 sa2 sa3) m (RD2 sa4 sa5)+-- cascading cases+shiftA !n (Node (FD1 sa1) m RD0) sa3+  = ShiftedA sa1 $+      case viewA (A.twice n) m of+        EmptyA -> singletonA sa3+        ConsA sam m'+          | (sam1, sam2) <- A.splitArray n sam+          -> Node (FD2 sam1 sam2) m' (RD1 sa3)+shiftA !n (Node (FD1 sa1) m (RD1 sa2)) sa3+    -- We force sa3 here to avoid forming a chain of thunks if+    -- we have a bunch of FD1+RD1 nodes in a row.+  = ShiftedA sa1 $ sa3 `seq`+      case shiftA (A.twice n) m (A.append n sa2 sa3) of+        ShiftedA sam m'+          | (sam1, sam2) <- A.splitArray n sam+          -> Node (FD2 sam1 sam2) m' RD0+shiftA n (Node (FD1 sa1) m (RD2 sa2 sa3)) sa4+  = ShiftedA sa1 $+      case shiftA (A.twice n) m (A.append n sa2 sa3) of+        ShiftedA sam m'+          | (sam1, sam2) <- A.splitArray n sam+          -> Node (FD2 sam1 sam2) m' (RD1 sa4)+shiftA n (Node (FD2 sa1 sa2) m (RD2 sa3 sa4)) sa5+  = ShiftedA sa1 $+      case shiftA (A.twice n) m (A.append n sa3 sa4) of+        ShiftedA sam m'+          | (sam1, sam2) <- A.splitArray n sam+          -> Node (FD3 sa2 sam1 sam2) m' (RD1 sa5)+shiftA n (Node (FD3 sa1 sa2 sa3) m (RD2 sa4 sa5)) sa6+  = ShiftedA sa1 $ Node (FD2 sa2 sa3) (snocA (A.twice n) m (A.append n sa4 sa5)) (RD1 sa6)++data ShiftedA n a = ShiftedA !(Array n a) (Queue n a)++{-+splitArray :: SmallArray a -> (SmallArray a, SmallArray a)+splitArray sa1 = (sa2, sa3)+  where+    !len' = A.sizeofSmallArray sa1 `quot` 2+    !sa2 = A.cloneSmallArray sa1 0 len'+    !sa3 = A.cloneSmallArray sa1 len' len'+-}++instance Show a => Show (Queue n a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (F.toList xs)++instance Eq a => Eq (Queue n a) where+  (==) = (==) `on` F.toList++instance Ord a => Ord (Queue n a) where+  compare = compare `on` F.toList++instance Foldable (Queue n) where+  foldMap _f Empty = mempty+  foldMap f (Node pr m sf) = foldMap f pr <> foldMap f m <> foldMap f sf++  null Empty = True+  null _ = False++  -- TODO: Once the size type has really stabilized,+  -- we should find a way to write a custom length.+  -- Until then, we leave that to the wrapper implementation.
+ src/Data/CompactSequence/Queue/Simple.hs view
@@ -0,0 +1,190 @@+{-# language DeriveTraversable #-}+{-# language ScopedTypeVariables #-}+{-# language BangPatterns #-}+{-# language MagicHash #-}+{-# language UnboxedTuples #-}+{-# language DataKinds #-}+{-# language PatternSynonyms #-}+{-# language ViewPatterns #-}+{-# language Trustworthy #-}+{-# language TypeFamilies #-}+-- {-# OPTIONS_GHC -Wall #-}++{- |+Space-efficient queues with amortized \( O(\log n) \) operations.  These+directly use an underlying array-based implementation, without doing any+special optimization for the first few and last few elements of the queue.+-}++module Data.CompactSequence.Queue.Simple+  ( Queue (Empty, (:<))+  , (|>)+  , empty+  , snoc+  , uncons+  , fromList+  , fromListN+  ) where++import qualified Data.CompactSequence.Queue.Internal as Q+import qualified Data.CompactSequence.Internal.Array as A+import qualified Data.Foldable as F+import qualified GHC.Exts as Exts+import Control.Monad.Trans.State.Strict++newtype Queue a = Queue (Q.Queue 'A.Mul1 a)+  deriving (Functor, Traversable, Eq, Ord)++empty :: Queue a+empty = Queue Q.empty++snoc :: Queue a -> a -> Queue a+snoc (Queue q) a = Queue $ Q.snocA A.one q (A.singleton a)++(|>) :: Queue a -> a -> Queue a+(|>) = snoc++uncons :: Queue a -> Maybe (a, Queue a)+uncons (Queue q) = case Q.viewA A.one q of+  Q.EmptyA -> Nothing+  Q.ConsA sa q'+    | (# a #) <- A.getSingleton# sa+    -> Just (a, Queue q')++infixr 4 :<+infixl 4 `snoc`++pattern (:<) :: a -> Queue a -> Queue a+pattern x :< xs <- (uncons -> Just (x, xs))++pattern Empty :: Queue a+pattern Empty = Queue Q.Empty+{-# COMPLETE (:<), Empty #-}++instance Foldable Queue where+  -- TODO: Implement more methods.+  foldMap f (Queue q) = foldMap f q+  foldr c n (Queue q) = foldr c n q+  foldl' f b (Queue q) = F.foldl' f b q+  -- Note: length only does O(log n) *unshared* work, but it does O(n) amortized+  -- work because it has to force the entire spine. We could avoid+  -- this, of course, by storing the size with the queue.+  length (Queue q) = go 0 A.one q+    where+      go :: Int -> A.Size m -> Q.Queue m a -> Int+      go !acc !_s Q.Empty = acc+      go !acc !s (Q.Node pr m sf) = go (acc + lpr + lsf) (A.twice s) m+        where+          lpr = case pr of+                  Q.FD1{} -> A.getSize s+                  Q.FD2{} -> 2*A.getSize s+                  Q.FD3{} -> 3*A.getSize s+          lsf = case sf of+                  Q.RD0 -> 0+                  Q.RD1{} -> A.getSize s+                  Q.RD2{} -> 2*A.getSize s++instance Show a => Show (Queue a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (F.toList xs)++instance Exts.IsList (Queue a) where+  type Item (Queue a) = a+  toList = F.toList+  fromList = fromList+  fromListN = fromListN++instance Semigroup (Queue a) where+  -- This gives us O(m + n) append, which I believe is the best we can do in+  -- general.+  --+  -- TODO: detect when the second queue is short enough that it's better to+  -- just insert all its elements into the first queue. This happens around+  -- when n log m < k (m + n), but finding the appropriate k requires+  -- benchmarking. Can we make that decision without fully calculating+  -- m or log m (using successive lower bounds)?+  Empty <> q = q+  q <> Empty = q+  q <> r = fromListN (length q + length r) (F.toList q ++ F.toList r)++instance Monoid (Queue a) where+  mempty = empty++-- | \( O(n \log n) \). Convert a list to a 'Queue', with the head of the+-- list at the front of the queue.+fromList :: [a] -> Queue a+fromList = F.foldl' snoc empty++-- | \( O(n) \). Convert a list of the given size to a 'Queue', with the+-- head of the list at the front of the queue.+fromListN :: Int -> [a] -> Queue a+fromListN n xs+  | (q,[]) <- runState (fromListQN A.one (intToQueueNum n)) xs+  = Queue q+  | otherwise+  = error "Data.CompactSequence.Queue.fromListN: list too long"++-- We use a similar approach to the one we use for stacks.  We should be able+-- to speed up the calculation of the QueueNum, perhaps even reducing its order+-- of growth, but this is sufficient to get linear-time conversion. Every node+-- of the resulting queue will be safe, except possibly the last one. This+-- should make the resulting queue cheap to work with initially.++data QueueNum+  = EmptyNum+  | NodeNum !FNum !QueueNum !RNum+data FNum = FN1 | FN2 | FN3+data RNum = RN0 | RN1 | RN2++fromListQN :: A.Size n -> QueueNum -> State [a] (Q.Queue n a)+fromListQN !_ EmptyNum = pure Q.empty+fromListQN !n (NodeNum prn mn sfn)+  = case prn of+      FN1 -> do+        sa <- state (A.arraySplitListN n)+        m  <- fromListQN (A.twice n) mn+        sf <- fromListRearQN n sfn+        pure (Q.Node (Q.FD1 sa) m sf)+      FN2 -> do+        sa1 <- state (A.arraySplitListN n)+        sa2 <- state (A.arraySplitListN n)+        m  <- fromListQN (A.twice n) mn+        sf <- fromListRearQN n sfn+        pure (Q.Node (Q.FD2 sa1 sa2) m sf)+      FN3 -> do+        sa1 <- state (A.arraySplitListN n)+        sa2 <- state (A.arraySplitListN n)+        sa3 <- state (A.arraySplitListN n)+        m  <- fromListQN (A.twice n) mn+        sf <- fromListRearQN n sfn+        pure (Q.Node (Q.FD3 sa1 sa2 sa3) m sf)+               +fromListRearQN :: A.Size n -> RNum -> State [a] (Q.RD n a)+fromListRearQN !_ RN0 = pure Q.RD0+fromListRearQN !n RN1 = do+    sa <- state (A.arraySplitListN n)+    pure (Q.RD1 sa)+fromListRearQN !n RN2 = do+    sa1 <- state (A.arraySplitListN n)+    sa2 <- state (A.arraySplitListN n)+    pure (Q.RD2 sa1 sa2)++intToQueueNum :: Int -> QueueNum+intToQueueNum = go EmptyNum+  where+    go !qn 0 = qn+    go !qn n = go (incQueueNum qn) (n - 1)++-- Note: this is not structured at all like `snoc`, because it makes no+-- semantic difference whether an increment occurs at the front or at the rear.+-- We ensure that every node is safe, except possibly the last one. We also+-- lean toward placing elements in the front.+incQueueNum :: QueueNum -> QueueNum+incQueueNum EmptyNum = NodeNum FN1 EmptyNum RN0+incQueueNum (NodeNum FN1 m sf) = NodeNum FN2 m sf+incQueueNum (NodeNum FN2 m sf) = NodeNum FN3 m sf+incQueueNum (NodeNum FN3 m RN0) = NodeNum FN3 m RN1+incQueueNum (NodeNum FN3 m RN1) = NodeNum FN3 (incQueueNum m) RN0+-- The last case is never used by intToQueueNum, because+-- incQueueNum never produces RN2 if it's not given it.+incQueueNum (NodeNum FN3 m RN2) = NodeNum FN3 (incQueueNum m) RN1
+ src/Data/CompactSequence/Stack/Internal.hs view
@@ -0,0 +1,167 @@+{-# language BangPatterns, DeriveTraversable #-}+{-# language TypeFamilies #-}+{-# language DataKinds #-}+{-# language TypeOperators #-}+{-# language NoStarIsType #-}+{-# language Safe #-}+{-# language ScopedTypeVariables #-}+{-# language InstanceSigs #-}+module Data.CompactSequence.Stack.Internal where+import qualified Data.Foldable as F+import qualified Data.CompactSequence.Internal.Array.Safe as A+import Data.CompactSequence.Internal.Array.Safe (Array, Size)+import Data.Function (on)+import Data.Traversable (foldMapDefault)+import Prelude++data Stack n a+  = Empty+  | One !(Array n a) !(Stack ('A.Twice n) a)+  | Two !(Array n a) !(Array n a) (Stack ('A.Twice n) a)+  | Three !(Array n a) !(Array n a) !(Array n a) !(Stack ('A.Twice n) a)+  deriving (Functor, Traversable)+{-+Debit invariant: We allow the Stack in each Two node as many debits as there+are elements in its array and those of all previous Two nodes.++We derive Functor and Traversable, at least for now, even though the derived+fmap and traverse can produce extra thunks below Two nodes. For Functor, there+seems to be no possible advantage to being stricter, except possibly to get+more consistent performance with different stack shapes--all we could do would+be to push the thunks to the leaves, which is really always worse. I suspect+the same is true for traverse, but I'm not entirely sure.+-}++instance Eq a => Eq (Stack n a) where+  (==) = (==) `on` F.toList++instance Ord a => Ord (Stack n a) where+  compare = compare `on` F.toList++instance Show a => Show (Stack n a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (F.toList xs)++instance Foldable (Stack n) where+  foldMap f xs = foldMapDefault f xs++  foldr :: forall a b. (a -> b -> b) -> b -> Stack n a -> b+  foldr c n = go+    where+      go :: Stack m a -> b+      go Empty = n+      go (One sa more)+        = foldr c (go more) sa+      go (Two sa1 sa2 more)+        = foldr c (foldr c (go more) sa2) sa1+      go (Three sa1 sa2 sa3 more)+        = foldr c (foldr c (foldr c (go more) sa3) sa2) sa1+  {-# INLINE foldr #-}++  null Empty = True+  null _ = False++  -- TODO: Once the size representation is properly sorted,+  -- we should implement a custom length method.++  -- length does O(log n) *unshared* work, but since+  -- it forces the spine it does O(n) *amortized* work.+  -- The right way to get stack sizes efficiently is to track+  -- them separately.+  length = go 1 0+    where+      go :: Int -> Int -> Stack m a -> Int+      go !_s acc Empty = acc+      go s acc (One _ more) = go (2*s) (acc + s) more+      go s acc (Two _ _ more) = go (2*s) (acc + 2*s) more+      go s acc (Three _ _ _ more) = go (2*s) (acc + 3*s) more++empty :: Stack n a+empty = Empty++consA :: Size n -> Array n a -> Stack n a -> Stack n a+consA !_ sa Empty = One sa Empty+consA !_ sa1 (One sa2 more) = Two sa1 sa2 more+consA !_ sa1 (Two sa2 sa3 more) = Three sa1 sa2 sa3 more+consA n sa1 (Three sa2 sa3 sa4 more) = Two sa1 sa2 (consA (A.twice n) (A.append n sa3 sa4) more)++{-+Empty is always trivial.++One: We increase the debit allowance below.++Two: We reduce the debit allowance of some nodes below by 2. We pay 2*log n to+discharge the excess debits.++Three: This is the tricky case for `cons`. We have some number of Three+nodes followed by something else. For each `Three` node, we suspend `s/4`+array-doubling work. We pay for that using the additional debit allowance+we gain from the elements in the new `Two` node. When we reach the end+of the `Three` chain, we have either `Empty`, `One`, or `Two`. If we have+`Empty` or `One`, we're done. If we have `Two`, then changing that to+`Three` reduces the debit allowance below. But we also *gain* debit allowance+below, from all the `Three`s that have changed to `Two`s! Our net loss+debit allowance is just 1, so we're golden.++1 2 4+Three Three Two more+-> Two Two Three more+`more` starts with a debit allowance of 8. The Three node in the+result has a debit allowance of 6. We suspend 3/2 array-doubling+work total and pass the debits from the `Stack` in the last `Two`+up to the one in the first `Two`.++Three Three Three Two more+-> Two Two Two Three more+`more` starts witha  debit allowance of 16. The Three node in the+result has a debit allowance of 14. We suspend 7/2 array doubling+work. Of that, 1/2 is in the first Two, 2/2 is in the second Two,+and 4/2 is in the last Two; we pass the debits on the last up, to+get 2/2 in the first Two and 4/2 in the second.++Three Three Three Three Two more+-> Two Two Two Two Three more+We suspend 15/2 array doubling work:+1    2    4    0+1/2, 2/2, 4/2, 8/2+1/2     1     2++Three Three Three Three Three Two more+We suspend 31/2 array doubling work:+1    2    4    8    0+1/2, 2/2, 4/2, 8/2, 16/2+1/2, 2/2, 4/2, 8/2+++Three Three One more+-> Two Two Two more++-}++data ViewA n a = EmptyA | ConsA !(Array n a) (Stack n a)++unconsA :: Size n -> Stack n a -> ViewA n a+unconsA !_ Empty = EmptyA+unconsA !_ (Three sa1 sa2 sa3 more) = ConsA sa1 (Two sa2 sa3 more)+unconsA !_ (Two sa1 sa2 more) = ConsA sa1 (One sa2 more)+unconsA n (One sa more) = ConsA sa $+  case unconsA (A.twice n) more of+    EmptyA -> Empty+    ConsA sa1 more' -> Two sa2 sa3 more'+      where+        (sa2, sa3) = A.splitArray n sa1++{-+Cases:+Empty is trivial.+`Three`: we increase the debit allowance below.+`Two`: We reduce the debit allowance on certain nodes by 2; pay 2*log n to discharge that.+`One`: This is the hard case. We have some number of `One` nodes followed by something else.+For each `One`, we perform a split. We place debits to pay for those, discharging the ones+at the root. At the end, we have a situation similar to that for `cons`: the tricky case+is ending in `Two`, where we use the fact that all the new `Two`s pay for the loss of the+final `Two`.+++One One One Two+-}
+ src/Data/CompactSequence/Stack/Simple.hs view
@@ -0,0 +1,161 @@+{-# language DataKinds #-}+{-# language BangPatterns #-}+{-# language PatternSynonyms #-}+{-# language ViewPatterns #-}+{-# language TypeFamilies #-}+{-# language DeriveTraversable #-}+-- We need Trustworthy for the IsList instance. *sigh*+{-# language Trustworthy #-}++{- |+Space-efficient stacks with amortized \( O(\log n) \) operations.+These directly use an underlying array-based implementation,+without doing any special optimization for the very top of the+stack.+-}++module Data.CompactSequence.Stack.Simple+  ( Stack (Empty, (:<))+  , empty+  , cons+  , (<|)+  , uncons+  , fromListN+  ) where++import qualified Data.CompactSequence.Stack.Internal as S+import Data.CompactSequence.Stack.Internal (consA, unconsA, ViewA (..))+import qualified Data.CompactSequence.Internal.Array.Safe as A+import qualified Data.Foldable as F+import qualified GHC.Exts as Exts++newtype Stack a = Stack {unStack :: S.Stack A.Mul1 a}+  deriving (Functor, Traversable, Eq, Ord)+  -- TODO: Write a custom Traversable instance to avoid+  -- an extra fmap at the top.++empty :: Stack a+empty = Stack S.empty++infixr 4 `cons`, :<, <|+cons :: a -> Stack a -> Stack a+cons a (Stack s) = Stack $ consA A.one (A.singleton a) s++uncons :: Stack a -> Maybe (a, Stack a)+uncons (Stack stk) = do+  ConsA sa stk' <- pure $ unconsA A.one stk+  hd <- A.getSingletonA sa+  Just (hd, Stack stk')++(<|) :: a -> Stack a -> Stack a+(<|) = cons++pattern (:<) :: a -> Stack a -> Stack a+pattern x :< xs <- (uncons -> Just (x, xs))+  where+    (:<) = cons++pattern Empty :: Stack a+pattern Empty = Stack S.Empty++{-# COMPLETE (:<), Empty #-}++instance Foldable Stack where+  -- TODO: implement more methods.+  foldMap f (Stack s) = foldMap f s+  foldr c n (Stack s) = foldr c n s+  foldl' f b (Stack s) = F.foldl' f b s+  null (Stack s) = null s++  -- length does O(log n) *unshared* work, but since+  -- it forces the spine it does O(n) *amortized* work.+  -- The right way to get stack sizes efficiently is to track+  -- them separately.+  length (Stack xs) = go 1 0 xs+    where+      go :: Int -> Int -> S.Stack m a -> Int+      go !_s acc S.Empty = acc+      go s acc (S.One _ more) = go (2*s) (acc + s) more+      go s acc (S.Two _ _ more) = go (2*s) (acc + 2*s) more+      go s acc (S.Three _ _ _ more) = go (2*s) (acc + 3*s) more++instance Semigroup (Stack a) where+  -- This gives us O(m + n) append, which I believe is the best we can do in+  -- general.+  -- TODO: when the first stack is small enough, it's better to+  -- just push all its elements, in reverse, onto the second+  -- stack. Let's take advantage of that.+  Empty <> s = s+  s <> Empty = s+  s <> t = fromListN (length s + length t) (F.toList s ++ F.toList t)++instance Monoid (Stack a) where+  mempty = empty++instance Exts.IsList (Stack a) where+  type Item (Stack a) = a+  toList = F.toList+  fromList = fromList+  fromListN = fromListN++-- | \( O(n \log n) \). Convert a list to a stack, with the+-- first element of the list as the top of the stack.+fromList :: [a] -> Stack a+fromList = foldr cons empty++-- | \( O(n) \). Convert a list of known length to a stack,+-- with the first element of the list as the top of the stack.+fromListN :: Int -> [a] -> Stack a+fromListN s xs = Stack $ fromListSN A.one (intToStackNum s) xs++-- We implement fromListN using a sort of abstract interpretation.  The+-- StackNum type is a representation of the *shape* of a stack.  Incrementing+-- it takes O(1) amortized time and O(log n) worst-case time. We count up with+-- it all the way to the desired size and then build a stack with the shape it+-- indicates. +--+-- TODO: find a faster way. While this approach is much, much better than the+-- naive O(n log n) one, it's not great. The smallest improvement would be to+-- represent StackNum as a bitstring, with two bits per digit.  But it would be+-- much nicer to find a way to reduce the order of growth.++data StackNum+  = EmptyNum+  | OneNum !StackNum+  | TwoNum !StackNum+  | ThreeNum !StackNum++fromListSN :: A.Size n -> StackNum -> [a] -> S.Stack n a+fromListSN !_ EmptyNum xs+  | F.null xs = S.Empty+  | otherwise = error "Data.CompactSequence.Stack.fromListN: List too long."+fromListSN s (OneNum n') xs+  | (ar, xs') <- A.arraySplitListN s xs+  = S.One ar (fromListSN (A.twice s) n' xs')+fromListSN s (TwoNum n') xs+  | (ar1, xs') <- A.arraySplitListN s xs+  , (ar2, xs'') <- A.arraySplitListN s xs'+    -- We build eagerly to dispose of the list as soon as+    -- possible.+  = S.Two ar1 ar2 $! fromListSN (A.twice s) n' xs''+fromListSN s (ThreeNum n') xs+  | (ar1, xs') <- A.arraySplitListN s xs+  , (ar2, xs'') <- A.arraySplitListN s xs'+  , (ar3, xs''') <- A.arraySplitListN s xs''+  = S.Three ar1 ar2 ar3 (fromListSN (A.twice s) n' xs''')++intToStackNum :: Int -> StackNum+intToStackNum = go EmptyNum+  where+    go !sn 0 = sn+    go !sn n = go (incStackNum sn) (n - 1)++incStackNum :: StackNum -> StackNum+incStackNum EmptyNum = OneNum EmptyNum+incStackNum (OneNum n) = TwoNum n+incStackNum (TwoNum n) = ThreeNum n+incStackNum (ThreeNum n) = TwoNum (incStackNum n)++instance Show a => Show (Stack a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (F.toList xs)
+ test/MyLibTest.hs view
@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."