packages feed

extended-containers (empty) → 0.1.0.0

raw patch · 10 files changed

+1994/−0 lines, 10 filesdep +QuickCheckdep +basedep +extended-containerssetup-changed

Dependencies added: QuickCheck, base, extended-containers, hspec, transformers, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright konsumlamm (c) 2019++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 konsumlamm 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,9 @@+# extended-containers++This package provides container data structures, including heaps and array mapped tries.++## Plans++* add a `Data.Deque` module+* add sorting to `Data.AMT`+* make an `extended-containers-lens` package for [`lens`](https://hackage.haskell.org/package/lens) instances
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ extended-containers.cabal view
@@ -0,0 +1,60 @@+name:                extended-containers+version:             0.1.0.0+synopsis:            Heap and Vector container types+description:+  This package contains general-purpose implementations of various immutable container types+  including vectors, heaps and priority heaps.+homepage:            https://github.com/konsumlamm/extended-containers#readme+bug-reports:         https://github.com/konsumlamm/extended-containers/issues+license:             BSD3+license-file:        LICENSE+author:              konsumlamm+maintainer:          konsumlamm@gmail.com+copyright:           2019 konsumlamm+build-type:          Simple+extra-source-files:  README.md+category:            Data Structures+cabal-version:       >= 1.10+tested-with:+  GHC == 8.0.1,+  GHC == 8.0.2,+  GHC == 8.2.2,+  GHC == 8.4.3,+  GHC == 8.4.4,+  GHC == 8.6.3,+  GHC == 8.6.4,+  GHC == 8.6.5,+  GHC == 8.8.2,+  GHC == 8.8.3++source-repository head+  type:     git+  location: https://github.com/konsumlamm/extended-containers.git++library+  hs-source-dirs:      src+  exposed-modules:+    Data.AMT+    Data.Heap+    Data.PrioHeap+  other-modules:+    Data.Heap.Internal+    Util.Internal.StrictList+  ghc-options:         -O2 -Wall -Wno-name-shadowing -Wredundant-constraints+  build-depends:+    base         >= 4.9 && < 5,+    transformers >= 0.5.2 && < 0.6,+    vector       >= 0.11 && < 0.13+  default-language:    Haskell2010++test-suite test+  hs-source-dirs:      test+  main-is:             Spec.hs+  type:                exitcode-stdio-1.0+  ghc-options:         -Wall -Wno-orphans+  build-depends:+    base                >= 4.9 && < 5,+    extended-containers,+    hspec               >= 2.2.4 && < 2.8,+    QuickCheck          >= 2.8.2 && < 2.15+  default-language:    Haskell2010
+ src/Data/AMT.hs view
@@ -0,0 +1,562 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE TypeFamilies #-}+#endif++{- |+= Finite vectors++The @'Vector' a@ type represents a finite vector (or dynamic array) of elements of type @a@.+A 'Vector' is strict in its spine.++The class instances are based on those for lists.++This module should be imported qualified, to avoid name clashes with the 'Prelude'.++> import qualified Data.AMT as Vector++== Performance++The worst case running time complexities are given, with /n/ referring the the number of elements in the vector.+A 'Vector' is particularly efficient for applications that require a lot of indexing and updates.+All logarithms are base 16, which means that /O(log n)/ behaves like /O(1)/ in practice.++== Warning++The length of a 'Vector' must not exceed @'maxBound' :: 'Int'@.+Violation of this condition is not detected and if the length limit is exceeded, the behaviour of the vector is undefined.++== Implementation++The implementation of 'Vector' uses array mapped tries.+-}++module Data.AMT+    ( Vector+    -- * Construction+    , empty, singleton, fromList+    , fromFunction+    , replicate, replicateA+    , unfoldr, unfoldl, iterateN+    , (<|), (|>), (><)+    -- * Deconstruction/Subranges+    , viewl+    , viewr+    , last+    , take+    -- * Indexing+    , lookup, index+    , (!?), (!)+    , update+    , adjust+    -- * Transformations+    , map, mapWithIndex+    , traverseWithIndex+    , indexed+    -- * Folds+    , foldMapWithIndex+    , foldlWithIndex, foldrWithIndex+    , foldlWithIndex', foldrWithIndex'+    -- * Zipping/Unzipping+    , zip, zipWith+    , zip3, zipWith3+    , unzip, unzip3+    -- * To Lists+    , toIndexedList+    ) where++import Control.Applicative (Alternative)+import qualified Control.Applicative as Applicative+import Control.Monad (MonadPlus(..))+#if !(MIN_VERSION_base(4,13,0))+import Control.Monad.Fail (MonadFail(..))+#endif+import Control.Monad.Zip (MonadZip(..))++import Data.Bits+import Data.Foldable (foldl', toList)+import Data.Functor.Classes+import Data.Functor.Compose+import Data.Functor.Identity+import Data.List.NonEmpty (NonEmpty(..), (!!))+import qualified Data.List.NonEmpty as L+import Data.Maybe (fromMaybe)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup((<>)))+#endif+#ifdef __GLASGOW_HASKELL__+import Data.String (IsString)+#endif+import Data.Traversable (mapAccumL)+#ifdef __GLASGOW_HASKELL__+import GHC.Exts (IsList)+import qualified GHC.Exts as Exts+#endif+import Prelude hiding ((!!), last, lookup, map, replicate, tail, take, unzip, unzip3, zip, zipWith, zip3, zipWith3)+import qualified Prelude as P+import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec)++import Control.Monad.Trans.State.Strict (state, evalState)+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as M++infixr 5 ><+infixr 5 <|+infixl 5 |>++data Tree a+    = Internal !(V.Vector (Tree a))+    | Leaf !(V.Vector a)++-- | An array mapped trie.+data Vector a+    = Empty+    | Root+        {-# UNPACK #-} !Int  -- size+        {-# UNPACK #-} !Int  -- offset (number of elements in the tree)+        {-# UNPACK #-} !Int  -- height (of the tree)+        !(Tree a)  -- tree+        !(NonEmpty a)  -- tail (reversed)++errorNegativeLength :: String -> a+errorNegativeLength s = error $ "AMT." ++ s ++ ": expected a nonnegative length"++-- The number of bits used per level.+bits :: Int+bits = 4+{-# INLINE bits #-}++-- The maximum size of the tail.+tailSize :: Int+tailSize = 1 `shiftL` bits++-- The mask used to extract the index into the array.+mask :: Int+mask = tailSize - 1++instance Show1 Vector where+    liftShowsPrec sp sl p v = showsUnaryWith (liftShowsPrec sp sl) "fromList" p (toList v)++instance Show a => Show (Vector a) where+    showsPrec = showsPrec1+    {-# INLINE showsPrec #-}++instance Read1 Vector where+    liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp rl) "fromList" fromList++instance Read a => Read (Vector a) where+#ifdef __GLASGOW_HASKELL__+    readPrec = parens $ prec 10 $ do+        Ident "fromList" <- lexP+        xs <- readPrec+        pure (fromList xs)+#else+    readsPrec = readsPrec1+    {-# INLINE readsPrec #-}+#endif++instance Eq1 Vector where+    liftEq f v1 v2 = length v1 == length v2 && liftEq f (toList v1) (toList v2)++instance Eq a => Eq (Vector a) where+    (==) = eq1+    {-# INLINE (==) #-}++instance Ord1 Vector where+    liftCompare f v1 v2 = liftCompare f (toList v1) (toList v2)++instance Ord a => Ord (Vector a) where+    compare = compare1+    {-# INLINE compare #-}++instance Semigroup (Vector a) where+    (<>) = (><)+    {-# INLINE (<>) #-}++instance Monoid (Vector a) where+    mempty = empty+    {-# INLINE mempty #-}++    mappend = (<>)+    {-# INLINE mappend #-}++instance Foldable Vector where+    foldr _ acc Empty = acc+    foldr f acc (Root _ _ _ tree tail) = foldrTree tree (foldr f acc (L.reverse tail))+      where+        foldrTree (Internal v) acc' = foldr foldrTree acc' v+        foldrTree (Leaf v) acc' = foldr f acc' v++    null Empty = True+    null Root{} = False+    {-# INLINE null #-}++    length Empty = 0+    length (Root s _ _ _ _) = s+    {-# INLINE length #-}++instance Functor Vector where+    fmap = map+    {-# INLINE fmap #-}++instance Traversable Vector where+    traverse _ Empty = pure Empty+    traverse f (Root s offset h tree tail) =+        Root s offset h <$> traverseTree tree <*> (L.reverse <$> traverse f (L.reverse tail))+      where+        traverseTree (Internal v) = Internal <$> traverse traverseTree v+        traverseTree (Leaf v) = Leaf <$> traverse f v++#ifdef __GLASGOW_HASKELL__+instance IsList (Vector a) where+    type Item (Vector a) = a++    fromList = fromList+    {-# INLINE fromList #-}++    toList = toList+    {-# INLINE toList #-}++instance a ~ Char => IsString (Vector a) where+    fromString = fromList+    {-# INLINE fromString #-}+#endif++instance Applicative Vector where+    pure = singleton+    {-# INLINE pure #-}++    fs <*> xs = foldl' (\acc f -> acc >< map f xs) empty fs++instance Monad Vector where+    xs >>= f = foldl' (\acc x -> acc >< f x) empty xs++instance Alternative Vector where+    empty = empty+    {-# INLINE empty #-}++    (<|>) = (><)+    {-# INLINE (<|>) #-}++instance MonadPlus Vector++instance MonadFail Vector where+    fail _ = empty+    {-# INLINE fail #-}++instance MonadZip Vector where+    mzip = zip+    {-# INLINE mzip #-}++    mzipWith = zipWith+    {-# INLINE mzipWith #-}++    munzip = unzip+    {-# INLINE munzip #-}+++-- | /O(1)/. The empty vector.+--+-- > empty = fromList []+empty :: Vector a+empty = Empty+{-# INLINE empty #-}++-- | /O(1)/. A vector with a single element.+--+-- > singleton x = fromList [x]+singleton :: a -> Vector a+singleton x = Root 1 0 0 (Leaf V.empty) (x :| [])+{-# INLINE singleton #-}++-- | /O(n * log n)/. Create a new vector from a list.+fromList :: [a] -> Vector a+fromList = foldl' (|>) empty+{-# INLINE fromList #-}++-- | Create a new vector of the given length from a function.+fromFunction :: Int -> (Int -> a) -> Vector a+fromFunction n f = if n < 0 then errorNegativeLength "fromFunction" else go 0 empty+  where+    go i acc+        | i < n = go (i + 1) (acc |> f i)+        | otherwise = acc+{-# INLINE fromFunction #-}++-- | /O(n * log n)/. @replicate n x@ is a vector consisting of n copies of x.+replicate :: Int -> a -> Vector a+replicate n = if n < 0 then errorNegativeLength "replicate" else runIdentity . replicateA n . Identity+{-# INLINE replicate #-}++-- | @replicateA@ is an 'Applicative' version of 'replicate'.+replicateA :: Applicative f => Int -> f a -> f (Vector a)+replicateA n x = if n < 0 then errorNegativeLength "replicateA" else go 0 (pure empty)+  where+    go i acc+        | i < n = go (i + 1) ((|>) <$> acc <*> x)+        | otherwise = acc+{-# INLINE replicateA #-}++-- | /O(n * log n)/. Build a vector from left to right by repeatedly applying a function to a seed value.+unfoldr :: (b -> Maybe (a, b)) -> b -> Vector a+unfoldr f = go empty+  where+    go v acc = case f acc of+        Nothing -> v+        Just (x, acc') -> go (v |> x) acc'+{-# INLINE unfoldr #-}++-- | /O(n * log n)/. Build a vector from right to left by repeatedly applying a function to a seed value.+unfoldl :: (b -> Maybe (b, a)) -> b -> Vector a+unfoldl f = go+  where+    go acc = case f acc of+        Nothing -> empty+        Just (acc', x) -> go acc' |> x+{-# INLINE unfoldl #-}++-- | Constructs a vector by repeatedly applying a function to a seed value.+iterateN :: Int -> (a -> a) -> a -> Vector a+iterateN n f x = if n < 0 then errorNegativeLength "iterateN" else replicateA n (state (\y -> (y, f y))) `evalState` x+{-# INLINE iterateN #-}++-- | /O(n * log n)/. Add an element to the left end of the vector.+(<|) :: a -> Vector a -> Vector a+x <| v = fromList $ x : toList v++-- | /O(n * log n)/. The first element and the vector without the first element or 'Nothing' if the vector is empty.+viewl :: Vector a -> Maybe (a, Vector a)+viewl Empty = Nothing+viewl v@Root{} =+    let ls = toList v+    in Just (head ls, fromList $ P.tail ls)++-- | /O(log n)/. Add an element to the right end of the vector.+(|>) :: Vector a -> a -> Vector a+Empty |> x = singleton x+Root s offset h tree tail |> x+    | s .&. mask /= 0 = Root (s + 1) offset h tree (x L.<| tail)+    | offset == 0 = Root (s + 1) s (h + 1) (Leaf $ V.fromList (toList $ L.reverse tail)) (x :| [])+    | offset == 1 `shiftL` (bits * h) = Root (s + 1) s (h + 1) (Internal $ V.fromList [tree, newPath h]) (x :| [])+    | otherwise = Root (s + 1) s h (insertTail (bits * (h - 1)) tree) (x :| [])+  where+    -- create a new path from the old tail+    newPath 1 = Leaf $ V.fromList (toList $ L.reverse tail)+    newPath h = Internal $ V.singleton (newPath (h - 1))++    insertTail sh (Internal v)+        | index < V.length v = Internal $ V.modify (\v -> M.modify v (insertTail (sh - bits)) index) v+        | otherwise = Internal $ V.snoc v (newPath (sh `div` bits))+      where+        index = offset `shiftR` sh .&. mask+    insertTail _ (Leaf _) = Leaf $ V.fromList (toList $ L.reverse tail)++-- | /O(log n)/. The vector without the last element and the last element or 'Nothing' if the vector is empty.+viewr :: Vector a -> Maybe (Vector a, a)+viewr Empty = Nothing+viewr (Root s offset h tree (x :| tail))+    | not (null tail) = Just (Root (s - 1) offset h tree (L.fromList tail), x)+    | s == 1 = Just (Empty, x)+    | s == tailSize + 1 = Just (Root (s - 1) 0 0 (Leaf V.empty) (getTail tree), x)+    | otherwise =+        let sh = bits * (h - 1)+        in Just (normalize $ Root (s - 1) (offset - tailSize) h (unsnocTree sh tree) (getTail tree), x)+  where+    index' = offset - tailSize - 1++    unsnocTree sh (Internal v) =+        let subIndex = index' `shiftR` sh .&. mask+            new = V.take (subIndex + 1) v+        in Internal $ V.modify (\v -> M.modify v (unsnocTree (sh - bits)) subIndex) new+    unsnocTree _ (Leaf v) = Leaf v++    getTail (Internal v) = getTail (V.last v)+    getTail (Leaf v) = L.fromList . reverse $ toList v++    normalize (Root s offset h (Internal v) tail)+        | length v == 1 = Root s offset (h - 1) (v V.! 0) tail+    normalize v = v++-- | /O(1)/. The last element in the vector or 'Nothing' if the vector is empty.+last :: Vector a -> Maybe a+last Empty = Nothing+last (Root _ _ _ _ (x :| _)) = Just x+{-# INLINE last #-}++-- | /O(log n)/. Take the first n elements of the vector or the vector if n is larger than the length of the vector.+-- Returns the empty vector if n is negative.+take :: Int -> Vector a -> Vector a+take _ Empty = Empty+take n root@(Root s offset h tree tail)+    | n <= 0 = Empty+    | n >= s = root+    | n > offset = Root n offset h tree (L.fromList $ L.drop (s - n) tail)+    | n <= tailSize = Root n 0 0 (Leaf V.empty) (getTail (bits * (h - 1)) tree)+    | otherwise =+        let sh = bits * (h - 1)+        in normalize $ Root n ((n - 1) .&. complement mask) h (takeTree sh tree) (getTail sh tree)  -- n - 1 because if 'n .&. mask == 0', we need to subtract tailSize+  where+    -- index of the last element in the new vector+    index = n - 1++    index' = index - tailSize++    takeTree sh (Internal v) =+        let subIndex = index' `shiftR` sh .&. mask+            new = V.take (subIndex + 1) v+        in Internal $ V.modify (\v -> M.modify v (takeTree (sh - bits)) subIndex) new+    takeTree _ (Leaf v) = Leaf v++    getTail sh (Internal v) = getTail (sh - bits) (v V.! (index `shiftR` sh .&. mask))+    getTail _ (Leaf v) = L.fromList . reverse . P.take (index .&. mask + 1) $ toList v++    normalize (Root s offset h (Internal v) tail)+        | length v == 1 = normalize $ Root s offset (h - 1) (v V.! 0) tail+    normalize v = v++-- | /O(log n)/. The element at the index or 'Nothing' if the index is out of range.+lookup :: Int -> Vector a -> Maybe a+lookup _ Empty = Nothing+lookup i (Root s offset h tree tail)+    | i < 0 || i >= s = Nothing+    | i < offset = Just $ lookupTree (bits * (h - 1)) tree+    | otherwise = Just $ tail !! (s - i - 1)+  where+    lookupTree sh (Internal v) = lookupTree (sh - bits) (v V.! (i `shiftR` sh .&. mask))+    lookupTree _ (Leaf v) = v V.! (i .&. mask)++-- | /O(log n)/. The element at the index. Calls 'error' if the index is out of range.+index :: Int -> Vector a -> a+index i = fromMaybe (error "AMT.index: index out of range") . lookup i++-- | /O(log n)/. Flipped version of 'lookup'.+(!?) :: Vector a -> Int -> Maybe a+(!?) = flip lookup+{-# INLINE (!?) #-}++-- | /O(log n)/. Flipped version of 'lookup'.+(!) :: Vector a -> Int -> a+(!) = flip index+{-# INLINE (!) #-}++-- | /O(log n)/. Update the element at the index with a new element.+-- Returns the original vector if the index is out of range.+update :: Int -> a -> Vector a -> Vector a+update i x = adjust i (const x)+{-# INLINE update #-}++-- | /O(log n)/. Adjust the element at the index by applying the function to it.+-- Returns the original vector if the index is out of range.+adjust :: Int -> (a -> a) -> Vector a -> Vector a+adjust _ _ Empty = Empty+adjust i f root@(Root s offset h tree tail)+    | i < 0 || i >= s = root+    | i < offset = Root s offset h (adjustTree (bits * (h - 1)) tree) tail+    | otherwise = let (l, x : r) = L.splitAt (s - i - 1) tail in Root s offset h tree (L.fromList $ l ++ (f x : r))+  where+    adjustTree sh (Internal v) =+        let index = i `shiftR` sh .&. mask+        in Internal $ V.modify (\v -> M.modify v (adjustTree (sh - bits)) index) v+    adjustTree _ (Leaf v) =+        let index = i .&. mask+        in Leaf $ V.modify (\v -> M.modify v f index) v++-- | /O(m * log n)/. Concatenate two vectors.+(><) :: Vector a -> Vector a -> Vector a+Empty >< v = v+v >< Empty = v+v1 >< v2 = foldl' (|>) v1 v2+{-# INLINE (><) #-}++-- | /O(n)/. Map a function over the vector.+map :: (a -> b) -> Vector a -> Vector b+map _ Empty = Empty+map f (Root s offset h tree tail) = Root s offset h (mapTree tree) (fmap f tail)+  where+    mapTree (Internal v) = Internal (fmap mapTree v)+    mapTree (Leaf v) = Leaf (fmap f v)++-- | /O(n)/. Map a function that has access to the index of an element over the vector.+mapWithIndex :: (Int -> a -> b) -> Vector a -> Vector b+mapWithIndex f = snd . mapAccumL (\i x -> i `seq` (i + 1, f i x)) 0++-- | /O(n)/. Fold the values in the vector, using the given monoid.+foldMapWithIndex :: Monoid m => (Int -> a -> m) -> Vector a -> m+foldMapWithIndex f = foldrWithIndex (\i -> mappend . f i) mempty++-- | /O(n)/. Fold using the given left-associative function that has access to the index of an element.+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Vector a -> b+foldlWithIndex f acc v = foldl (\g x i -> i `seq` f (g (i - 1)) i x) (const acc) v (length v - 1)++-- | /O(n)/. Fold using the given right-associative function that has access to the index of an element.+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Vector a -> b+foldrWithIndex f acc v = foldr (\x g i -> i `seq` f i x (g (i + 1))) (const acc) v 0++-- | /O(n)/. A strict version of 'foldlWithIndex'.+-- Each application of the function is evaluated before using the result in the next application.+foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Vector a -> b+foldlWithIndex' f acc v = foldrWithIndex f' id v acc+  where+    f' i x k z = k $! f z i x+{-# INLINE foldlWithIndex' #-}++-- | /O(n)/. A strict version of 'foldrWithIndex'.+-- Each application of the function is evaluated before using the result in the next application.+foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Vector a -> b+foldrWithIndex' f acc v = foldlWithIndex f' id v acc+  where+    f' k i x z = k $! f i x z+{-# INLINE foldrWithIndex' #-}++-- | /O(n)/. Traverse the vector with a function that has access to the index of an element.+traverseWithIndex :: Applicative f => (Int -> a -> f b) -> Vector a -> f (Vector b)+traverseWithIndex f v = evalState (getCompose $ traverse (Compose . state . flip f') v) 0+  where+    f' i x = i `seq` (f i x, i + 1)++-- | /O(n)/. Pair each element in the vector with its index.+indexed :: Vector a -> Vector (Int, a)+indexed = mapWithIndex (,)+{-# INLINE indexed #-}++-- | /O(n)/. Takes two vectors and returns a vector of corresponding pairs.+zip :: Vector a -> Vector b -> Vector (a, b)+zip = zipWith (,)+{-# INLINE zip #-}++-- | /O(n)/. A generalized 'zip' zipping with a function.+zipWith :: (a -> b -> c) -> Vector a -> Vector b -> Vector c+zipWith f v1 v2+    | length v1 >= length v2 = snd $ mapAccumL f' (toList v1) v2+    | otherwise = zipWith (flip f) v2 v1+  where+    f' [] _ = error "unreachable"+    f' (x : xs) y = (xs, f x y)++-- | /O(n)/. Takes three vectors and returns a vector of corresponding triples.+zip3 :: Vector a -> Vector b -> Vector c -> Vector (a, b, c)+zip3 = zipWith3 (,,)+{-# INLINE zip3 #-}++-- | /O(n)/. A generalized 'zip3' zipping with a function.+zipWith3 :: (a -> b -> c -> d) -> Vector a -> Vector b -> Vector c -> Vector d+zipWith3 f v1 v2 v3 = zipWith ($) (zipWith f v1 v2) v3++-- | /O(n)/. Transforms a vector of pairs into a vector of first components and a vector of second components.+unzip :: Vector (a, b) -> (Vector a, Vector b)+unzip v = (map fst v, map snd v)+{-# INLINE unzip #-}++-- | /O(n)/. Takes a vector of triples and returns three vectors, analogous to 'unzip'.+unzip3 :: Vector (a, b, c) -> (Vector a, Vector b, Vector c)+unzip3 v = (map fst3 v, map snd3 v, map trd3 v)+  where+    fst3 (x, _, _) = x+    snd3 (_, y, _) = y+    trd3 (_, _, z) = z+{-# INLINE unzip3 #-}++-- | /O(n)/. Create a list of index-value pairs from the vector.+toIndexedList :: Vector a -> [(Int, a)]+toIndexedList = foldrWithIndex (curry (:)) []+{-# INLINE toIndexedList #-}
+ src/Data/Heap.hs view
@@ -0,0 +1,67 @@+{- |+= Finite heaps++The @'Heap' a@ type represents a finite heap (or priority queue) of elements of type @a@.+A 'Heap' is strict in its spine. Unlike with sets, duplicate elements are allowed.++== Performance++The worst case running time complexities are given, with /n/ referring the the number of elements in the heap.++== Warning++The length of a 'Heap' must not exceed @'maxBound' :: 'Int'@.+Violation of this condition is not detected and if the length limit is exceeded, the behaviour of the heap is undefined.++== Implementation++The implementation uses skew binomial heaps, as described in++* Chris Okasaki, \"Purely Functional Data Structures\", 1998+-}++module Data.Heap+    ( Heap+    -- * Construction+    , empty, singleton+    -- ** From Lists+    , fromList+    -- * Insertion/Union+    , insert+    , union, unions+    -- * Traversal/Filter+    , map, mapMonotonic+    , filter+    , partition+    -- * Ordered Folds+    , foldMapOrd+    , foldlOrd, foldrOrd+    , foldlOrd', foldrOrd'+    -- * Query+    , size+    , member, notMember+    -- * Min+    , lookupMin+    , findMin+    , deleteMin+    , deleteFindMin+    , minView+    -- * Subranges+    , take+    , drop+    , splitAt+    , takeWhile+    , dropWhile+    , span+    , break+    , nub+    -- * Conversion+    -- ** To Lists+    , toAscList, toDescList+    -- * Heapsort+    , heapsort+    ) where++import Prelude hiding (break, drop, dropWhile, filter, map, span, splitAt, take, takeWhile)++import Data.Heap.Internal
+ src/Data/Heap/Internal.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE TypeFamilies #-}+#endif++module Data.Heap.Internal+    ( Heap(..)+    , Tree(..)+    -- * Construction+    , empty, singleton+    -- ** From Lists+    , fromList+    -- * Insertion/Union+    , insert+    , union, unions+    -- * Traversal/Filter+    , map, mapMonotonic+    , filter+    , partition+    -- * Ordered Folds+    , foldMapOrd+    , foldlOrd, foldrOrd+    , foldlOrd', foldrOrd'+    -- * Query+    , size+    , member, notMember+    -- * Min+    , lookupMin+    , findMin+    , deleteMin+    , deleteFindMin+    , minView+    -- * Subranges+    , take+    , drop+    , splitAt+    , takeWhile+    , dropWhile+    , span+    , break+    , nub+    -- * Conversion+    -- ** To Lists+    , toAscList, toDescList+    -- * Heapsort+    , heapsort+    ) where++import Control.Exception (assert)+import Data.Foldable (foldl', toList)+import Data.Functor.Classes+import Data.Maybe (fromMaybe)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup((<>)))+#endif+#ifdef __GLASGOW_HASKELL__+import GHC.Exts (IsList)+import qualified GHC.Exts as Exts+#endif+import Prelude hiding (break, drop, dropWhile, filter, map, reverse, span, splitAt, take, takeWhile)+import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec)++import Util.Internal.StrictList++-- | A skew binomial heap.+data Heap a+    = Empty+    | Heap+        {-# UNPACK #-} !Int  -- size+        !a  -- root+        !(Forest a)  -- forest++type Forest a = List (Tree a)++data Tree a = Node+    { _rank :: {-# UNPACK #-} !Int+    , _root :: !a+    , _elements :: !(List a)+    , _children :: !(Forest a)+    }++errorEmpty :: String -> a+errorEmpty s = error $ "Heap." ++ s ++ ": empty heap"++instance Functor Tree where+    fmap f (Node r x xs c) = Node r (f x) (fmap f xs) (fmap (fmap f) c)++instance Foldable Tree where+    foldr f acc (Node _ x xs c) = f x (foldr f (foldr (flip (foldr f)) acc c) xs)++link :: Ord a => Tree a -> Tree a -> Tree a+link t1@(Node r1 x1 xs1 c1) t2@(Node r2 x2 xs2 c2) = assert (r1 == r2) $+    if x1 <= x2+        then Node (r1 + 1) x1 xs1 (t2 `Cons` c1)+        else Node (r2 + 1) x2 xs2 (t1 `Cons` c2)++skewLink :: Ord a => a -> Tree a -> Tree a -> Tree a+skewLink x t1 t2 = let Node r y ys c = link t1 t2+    in if x <= y+        then Node r x (y `Cons` ys) c+        else Node r y (x `Cons` ys) c++insTree :: Ord a => Tree a -> Forest a -> Forest a+insTree t Nil = t `Cons` Nil+insTree t1 f@(t2 `Cons` ts)+    | _rank t1 < _rank t2 = t1 `Cons` f+    | otherwise = insTree (link t1 t2) ts++mergeTrees :: Ord a => Forest a -> Forest a -> Forest a+mergeTrees f Nil = f+mergeTrees Nil f = f+mergeTrees f1@(t1 `Cons` ts1) f2@(t2 `Cons` ts2) = case _rank t1 `compare` _rank t2 of+    LT -> t1 `Cons` mergeTrees ts1 f2+    GT -> t2 `Cons` mergeTrees f1 ts2+    EQ -> insTree (link t1 t2) (mergeTrees ts1 ts2)++merge :: Ord a => Forest a -> Forest a -> Forest a+merge f1 f2 = mergeTrees (normalize f1) (normalize f2)+{-# INLINE merge #-}++normalize :: Ord a => Forest a -> Forest a+normalize Nil = Nil+normalize (t `Cons` ts) = insTree t ts+{-# INLiNE normalize #-}++ins :: Ord a => a -> Forest a -> Forest a+ins x (t1 `Cons` t2 `Cons` ts)+    | _rank t1 == _rank t2 = x `seq` skewLink x t1 t2 `Cons` ts+ins x ts = x `seq` Node 0 x Nil Nil `Cons` ts++fromForest :: Ord a => Int -> Forest a -> Heap a+fromForest _ Nil = Empty+fromForest s f@(_ `Cons` _) =+    let (Node _ x xs ts1, ts2) = removeMinTree f+    in Heap s x (foldl' (flip ins) (merge (reverse ts1) ts2) xs)++removeMinTree :: Ord a => Forest a -> (Tree a, Forest a)+removeMinTree Nil = error "removeMinTree: empty heap"+removeMinTree (t `Cons` Nil) = (t, Nil)+removeMinTree (t `Cons` ts) =+    let (t', ts') = removeMinTree ts+    in if _root t <= _root t'+        then (t, ts)+        else (t', t `Cons` ts')++instance Show1 Heap where+    liftShowsPrec sp sl p heap = showsUnaryWith (liftShowsPrec sp sl) "fromList" p (toList heap)++instance Show a => Show (Heap a) where+    showsPrec = showsPrec1+    {-# INLINE showsPrec #-}++instance (Ord a, Read a) => Read (Heap a) where+#ifdef __GLASGOW_HASKELL__+    readPrec = parens $ prec 10 $ do+        Ident "fromList" <- lexP+        xs <- readPrec+        pure (fromList xs)+#else+    readsPrec = readsData $ readsUnaryWith readList "fromList" fromList+#endif++instance Ord a => Eq (Heap a) where+    heap1 == heap2 = size heap1 == size heap2 && toAscList heap1 == toAscList heap2++instance Ord a => Ord (Heap a) where+    compare heap1 heap2 = compare (toAscList heap1) (toAscList heap2)++instance Ord a => Semigroup (Heap a) where+    (<>) = union+    {-# INLINE (<>) #-}++instance Ord a => Monoid (Heap a) where+    mempty = empty+    {-# INLINE mempty #-}++    mappend = (<>)+    {-# INLINE mappend #-}++instance Foldable Heap where+    foldr _ acc Empty = acc+    foldr f acc (Heap _ x forest) = f x (foldr (flip (foldr f)) acc forest)++    null Empty = True+    null Heap{} = False+    {-# INLINE null #-}++    length = size+    {-# INLINE length #-}++    minimum = findMin+    {-# INLINE minimum #-}++#ifdef __GLASGOW_HASKELL__+instance Ord a => IsList (Heap a) where+    type Item (Heap a) = a++    fromList = fromList+    {-# INLINE fromList #-}++    toList = toList+    {-# INLINE toList #-}+#endif+++-- | /O(1)/. The empty heap.+--+-- > empty = fromList []+empty :: Heap a+empty = Empty+{-# INLINE empty #-}++-- | /O(1)/. A heap with a single element.+--+-- > singleton x = fromList [x]+singleton :: a -> Heap a+singleton x = Heap 1 x Nil+{-# INLINE singleton #-}++-- | /O(n)/. Create a heap from a list.+fromList :: Ord a => [a] -> Heap a+fromList = foldl' (flip insert) empty+{-# INLINE fromList #-}++-- | /O(1)/. Insert a new value into the heap.+insert :: Ord a => a -> Heap a -> Heap a+insert x Empty = singleton x+insert x (Heap s y f)+    | x <= y = Heap (s + 1) x (ins y f)+    | otherwise = Heap (s + 1) y (ins x f)++-- | /O(log n)/. The union of two heaps.+union :: Ord a => Heap a -> Heap a -> Heap a+union heap Empty = heap+union Empty heap = heap+union (Heap s1 x1 f1) (Heap s2 x2 f2)+    | x1 <= x2 = Heap (s1 + s2) x1 (ins x2 (merge f1 f2))+    | otherwise = Heap (s1 + s2) x2 (ins x1 (merge f1 f2))++-- | The union of a foldable of heaps.+--+-- > unions = foldl union empty+unions :: (Foldable f, Ord a) => f (Heap a) -> Heap a+unions = foldl' union empty+{-# INLINE unions #-}++-- | /O(n)/. Map a function over the heap.+map :: Ord b => (a -> b) -> Heap a -> Heap b+map f = fromList . fmap f . toList+{-# INLINE map #-}++-- | /O(n)/, Map an increasing function over the heap. The precondition is not checked.+mapMonotonic :: (a -> b) -> Heap a -> Heap b+mapMonotonic _ Empty = Empty+mapMonotonic f (Heap s x forest) = Heap s (f x) (fmap (fmap f) forest)+{-# INLINE mapMonotonic #-}++-- | /O(n)/. Filter all elements that satisfy the predicate.+filter :: Ord a => (a -> Bool) -> Heap a -> Heap a+filter f = foldl' (\acc x -> if f x then insert x acc else acc) empty+{-# INLINE filter #-}++-- | /O(n)/. Partition the heap into two heaps, one with all elements that satisfy the predicate+-- and one with all elements that don't satisfy the predicate.+partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)+partition f = foldl' (\(h1, h2) x -> if f x then (insert x h1, h2) else (h1, insert x h2)) (empty, empty)+{-# INLINE partition #-}++-- | /O(n * log n)/. Fold the values in the heap in order, using the given monoid.+foldMapOrd :: (Ord a, Monoid m) => (a -> m) -> Heap a -> m+foldMapOrd f = foldrOrd (mappend . f) mempty++-- | /O(n * log n)/. Fold the values in the heap in order, using the given right-associative function.+foldrOrd :: Ord a => (a -> b -> b) -> b -> Heap a -> b+foldrOrd f acc = go+  where+    go h = case minView h of+        Nothing -> acc+        Just (x, h') -> f x (go h')++-- | /O(n * log n)/. Fold the values in the heap in order, using the given left-associative function.+foldlOrd :: Ord a => (b -> a -> b) -> b -> Heap a -> b+foldlOrd f = go+  where+    go acc h = case minView h of+        Nothing -> acc+        Just (x, h') -> go (f acc x) h'++-- | /O(n * log n)/. A strict version of 'foldrOrd'.+-- Each application of the function is evaluated before using the result in the next application.+foldrOrd' :: Ord a => (a -> b -> b) -> b -> Heap a -> b+foldrOrd' f acc h = foldlOrd f' id h acc+  where+    f' k x z = k $! f x z+{-# INLINE foldrOrd' #-}++-- | /O(n)/. A strict version of 'foldlOrd'.+-- Each application of the function is evaluated before using the result in the next application.+foldlOrd' :: Ord a => (b -> a -> b) -> b -> Heap a -> b+foldlOrd' f acc h = foldrOrd f' id h acc+  where+    f' x k z = k $! f z x+{-# INLINE foldlOrd' #-}++-- | /O(1)/. The number of elements in the heap.+size :: Heap a -> Int+size Empty = 0+size (Heap s _ _) = s+{-# INLINE size #-}++-- | /O(n)/. Is the value a member of the heap?+member :: Ord a => a -> Heap a -> Bool+member _ Empty = False+member x (Heap _ y forest) = x <= y && any (x `elemTree`) forest+  where+    x `elemTree` (Node _ y ys c) = x <= y && (x `elem` ys || any (x `elemTree`) c)++-- | /O(n)/. Is the value not a member of the heap?+notMember :: Ord a => a -> Heap a -> Bool+notMember x = not . member x++-- | /O(log n)/. The minimal element in the heap. Calls 'error' if the heap is empty.+findMin :: Heap a -> a+findMin Empty = error "findMin: empty heap"+findMin (Heap _ x _) = x+{-# INLINE findMin #-}++-- | /O(log n)/. The minimal element in the heap or 'Nothing' if the heap is empty.+lookupMin :: Heap a -> Maybe a+lookupMin Empty = Nothing+lookupMin (Heap _ x _) = Just $! x+{-# INLINE lookupMin #-}++-- | /O(log n)/. Delete the minimal element. Returns the empty heap if the heap is empty.+deleteMin :: Ord a => Heap a -> Heap a+deleteMin Empty = Empty+deleteMin (Heap s _ f) = fromForest (s - 1) f+{-# INLINE deleteMin #-}++-- | /O(log n)/. Delete and find the minimal element. Calls 'error' if the heap is empty.+--+-- > deleteFindMin heap = (findMin heap, deleteMin heap)+deleteFindMin :: Ord a => Heap a -> (a, Heap a)+deleteFindMin heap = fromMaybe (errorEmpty "deleteFindMin") (minView heap)+{-# INLINE deleteFindMin #-}++-- | /O(log n)/. Retrieves the minimal element of the heap and the heap stripped of that element or 'Nothing' if the heap is empty.+minView :: Ord a => Heap a -> Maybe (a, Heap a)+minView Empty = Nothing+minView (Heap s x f) = Just (x, fromForest (s - 1) f)+{-# INLINE minView #-}++-- | /O(n * log n)/. @take n heap@ takes the @n@ smallest elements of @heap@, in ascending order.+--+-- > take n heap = take n (toAscList heap)+take :: Ord a => Int -> Heap a -> [a]+take n h+    | n <= 0 = []+    | otherwise = case minView h of+        Nothing -> []+        Just (x, h') -> x : take (n - 1) h'++-- | /O(n * log n)/. @drop n heap@ drops the @n@ smallest elements from @heap@.+drop :: Ord a => Int -> Heap a -> Heap a+drop n h+    | n <= 0 = h+    | otherwise = drop (n - 1) (deleteMin h)++-- | /O(n * log n)/. @splitAt n heap@ takes and drops the @n@ smallest elements from @heap@.+--+-- > splitAt n heap = (take n heap, drop n heap)+splitAt :: Ord a => Int -> Heap a -> ([a], Heap a)+splitAt n h+    | n <= 0 = ([], h)+    | otherwise = case minView h of+        Nothing -> ([], h)+        Just (x, h') -> let (xs, h'') = splitAt (n - 1) h' in (x : xs, h'')++-- | /O(n * log n)/. @takeWhile p heap@ takes the elements from @heap@ in ascending order, while @p@ holds.+takeWhile :: Ord a => (a -> Bool) -> Heap a -> [a]+takeWhile p = go+  where+    go h = case minView h of+        Nothing -> []+        Just (x, h') -> if p x then x : go h' else []+{-# INLINE takeWhile #-}++-- | /O(n * log n)/. @dropWhile p heap@ drops the elements from @heap@ in ascending order, while @p@ holds.+dropWhile :: Ord a => (a -> Bool) -> Heap a -> Heap a+dropWhile p = go+  where+    go h = case minView h of+        Nothing -> h+        Just (x, h') -> if p x then go h' else h+{-# INLINE dropWhile #-}++-- | /O(n * log n)/. @span p heap@ takes and drops the elements from @heap@, while @p@ holds+--+-- > span p heap = (takeWhile p heap, dropWhile p heap)+span :: Ord a => (a -> Bool) -> Heap a -> ([a], Heap a)+span p = go+  where+    go h = case minView h of+        Nothing -> ([], h)+        Just (x, h') -> if p x+            then let (xs, h'') = go h' in (x : xs, h'')+            else ([], h)+{-# INLINE span #-}++-- | /O(n * log n)/. @span@, but with inverted predicate.+--+-- > break p = span (not . p)+break :: Ord a => (a -> Bool) -> Heap a -> ([a], Heap a)+break p = span (not . p)+{-# INLINE break #-}++-- | /O(n * log n)/. Remove duplicate elements from the heap.+nub :: Ord a => Heap a -> Heap a+nub h = case minView h of+    Nothing -> Empty+    Just (x, h') -> insert x (nub (dropWhile (== x) h'))++-- | /O(n * log n)/. Create a descending list from the heap.+toAscList :: Ord a => Heap a -> [a]+toAscList = foldrOrd (:) []+{-# INLINE toAscList #-}++-- | /O(n * log n)/. Create a descending list from the heap.+toDescList :: Ord a => Heap a -> [a]+toDescList = foldlOrd (flip (:)) []+{-# INLINE toDescList #-}++-- | /O(n * log n)/. Sort a list using a heap. The sort is unstable.+heapsort :: Ord a => [a] -> [a]+heapsort = toAscList . fromList+{-# INLINE heapsort #-}
+ src/Data/PrioHeap.hs view
@@ -0,0 +1,679 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE TypeFamilies #-}+#endif++{- |+= Finite priority heaps++The @'PrioHeap' k a@ type represents a finite heap (or priority queue) from keys/priorities of type @k@ to values of type @a@.+A 'PrioHeap' is strict in its spine. Unlike with maps, duplicate keys/priorities are allowed.++== Performance++The worst case running time complexities are given, with /n/ referring the the number of elements in the heap.++== Warning++The length of a 'PrioHeap' must not exceed @'maxBound' :: 'Int'@.+Violation of this condition is not detected and if the length limit is exceeded, the behaviour of the heap is undefined.++== Implementation++The implementation uses skew binomial heaps, as described in++* Chris Okasaki, \"Purely Functional Data Structures\", 1998+-}++module Data.PrioHeap+    ( PrioHeap+    -- * Construction+    , empty, singleton+    , fromHeap+    -- ** From Lists+    , fromList+    -- * Insertion/Union+    , insert+    , union, unions+    -- * Traversal/Filter+    , map, mapWithKey+    , traverseWithKey+    , filter, filterWithKey+    , partition, partitionWithKey+    , mapMaybe, mapMaybeWithKey+    , mapEither, mapEitherWithKey+    -- * Folds+    , foldMapWithKey+    , foldlWithKey, foldrWithKey+    , foldlWithKey', foldrWithKey'+    , foldMapOrd+    , foldlOrd, foldrOrd+    , foldlOrd', foldrOrd'+    , foldMapWithKeyOrd+    , foldlWithKeyOrd, foldrWithKeyOrd+    , foldlWithKeyOrd', foldrWithKeyOrd'+    -- * Query+    , size+    , member, notMember+    -- * Min+    , adjustMin, adjustMinWithKey+    , lookupMin+    , findMin+    , deleteMin+    , deleteFindMin+    , updateMin, updateMinWithKey+    , minView+    -- * Subranges+    , take+    , drop+    , splitAt+    , takeWhile, takeWhileWithKey+    , dropWhile, dropWhileWithKey+    , span, spanWithKey+    , break, breakWithKey+    , nub+    -- * Conversion+    , keysHeap+    -- ** To Lists+    , toList, toAscList, toDescList+    ) where++import Control.Exception (assert)+import Data.Foldable (foldl', foldr')+import Data.Functor.Classes+import Data.Maybe (fromMaybe)+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup((<>)))+#endif+#ifdef __GLASGOW_HASKELL__+import GHC.Exts (IsList)+import qualified GHC.Exts as Exts+#endif+import Prelude hiding (break, drop, dropWhile, filter, map, reverse, span, splitAt, take, takeWhile, uncurry)+import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec)++import qualified Data.Heap.Internal as Heap+import Util.Internal.StrictList++-- | A skew binomial heap with associated priorities.+data PrioHeap k a+    = Empty+    | Heap+        {-# UNPACK #-} !Int  -- size+        !k  -- root key+        a  -- root value+        !(Forest k a)  -- forest++type Forest k a = List (Tree k a)++data Pair k a = Pair !k a++data Tree k a = Node+    { _rank :: {-# UNPACK #-} !Int+    , _root :: !k+    , _value :: a+    , _elements :: !(List (Pair k a))+    , _children :: !(Forest k a)+    }++errorEmpty :: String -> a+errorEmpty s = error $ "PrioHeap." ++ s ++ ": empty heap"++uncurry :: (a -> b -> c) -> Pair a b -> c+uncurry f (Pair x y) = f x y+{-# INLINE uncurry #-}++link :: Ord k => Tree k a -> Tree k a -> Tree k a+link t1@(Node r1 key1 x1 xs1 c1) t2@(Node r2 key2 x2 xs2 c2) = assert (r1 == r2) $+    if key1 <= key2+        then Node (r1 + 1) key1 x1 xs1 (t2 `Cons` c1)+        else Node (r2 + 1) key2 x2 xs2 (t1 `Cons` c2)++skewLink :: Ord k => k -> a -> Tree k a -> Tree k a -> Tree k a+skewLink kx x t1 t2 = let Node r ky y ys c = link t1 t2+    in if kx <= ky+        then Node r kx x (Pair ky y `Cons` ys) c+        else Node r ky y (Pair kx x `Cons` ys) c++insTree :: Ord k => Tree k a -> Forest k a -> Forest k a+insTree t Nil = t `Cons` Nil+insTree t1 f@(t2 `Cons` ts)+    | _rank t1 < _rank t2 = t1 `Cons` f+    | otherwise = insTree (link t1 t2) ts++mergeTrees :: Ord k => Forest k a -> Forest k a -> Forest k a+mergeTrees f Nil = f+mergeTrees Nil f = f+mergeTrees f1@(t1 `Cons` ts1) f2@(t2 `Cons` ts2) = case _rank t1 `compare` _rank t2 of+    LT -> t1 `Cons` mergeTrees ts1 f2+    GT -> t2 `Cons` mergeTrees f1 ts2+    EQ -> insTree (link t1 t2) (mergeTrees ts1 ts2)++merge :: Ord k => Forest k a -> Forest k a -> Forest k a+merge f1 f2 = mergeTrees (normalize f1) (normalize f2)+{-# INLINE merge #-}++normalize :: Ord k => Forest k a -> Forest k a+normalize Nil = Nil+normalize (t `Cons` ts) = insTree t ts+{-# INLiNE normalize #-}++ins :: Ord k => k -> a -> Forest k a -> Forest k a+ins key x (t1 `Cons` t2 `Cons` ts)+    | _rank t1 == _rank t2 = key `seq` skewLink key x t1 t2 `Cons` ts+ins key x ts = key `seq` Node 0 key x Nil Nil `Cons` ts++fromForest :: Ord k => Int -> Forest k a -> PrioHeap k a+fromForest _ Nil = Empty+fromForest s f@(_ `Cons` _) =+    let (Node _ key x xs ts1, ts2) = removeMinTree f+    in Heap s key x (foldl' (\acc (Pair key x) -> ins key x acc) (merge (reverse ts1) ts2) xs)++removeMinTree :: Ord k => Forest k a -> (Tree k a, Forest k a)+removeMinTree Nil = error "removeMinTree: empty heap"+removeMinTree (t `Cons` Nil) = (t, Nil)+removeMinTree (t `Cons` ts) =+    let (t', ts') = removeMinTree ts+    in if _root t <= _root t'+        then (t, ts)+        else (t', t `Cons` ts')++instance Show2 PrioHeap where+    liftShowsPrec2 spk slk spv slv p heap = showsUnaryWith (liftShowsPrec sp sl) "fromList" p (toList heap)+      where+        sp = liftShowsPrec2 spk slk spv slv+        sl = liftShowList2 spk slk spv slv++instance Show k => Show1 (PrioHeap k) where+    liftShowsPrec = liftShowsPrec2 showsPrec showList+    {-# INLINE liftShowsPrec #-}++instance (Show k, Show a) => Show (PrioHeap k a) where+    showsPrec = showsPrec2+    {-# INLINE showsPrec #-}++instance (Ord k, Read k) => Read1 (PrioHeap k) where+    liftReadsPrec rp rl = readsData $ readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList+      where+        rp' = liftReadsPrec rp rl+        rl' = liftReadList rp rl++instance (Ord k, Read k, Read a) => Read (PrioHeap k a) where+#ifdef __GLASGOW_HASKELL__+    readPrec = parens $ prec 10 $ do+        Ident "fromList" <- lexP+        xs <- readPrec+        pure (fromList xs)+#else+    readsPrec = readsPrec1+    {-# INLINE readPrec #-}+#endif++instance Ord k => Eq1 (PrioHeap k) where+    liftEq f heap1 heap2 = size heap1 == size heap2 && liftEq (liftEq f) (toAscList heap1) (toAscList heap2)++instance (Ord k, Eq a) => Eq (PrioHeap k a) where+    (==) = eq1+    {-# INLINE (==) #-}++instance Ord k => Ord1 (PrioHeap k) where+    liftCompare f heap1 heap2 = liftCompare (liftCompare f) (toAscList heap1) (toAscList heap2)++instance (Ord k, Ord a) => Ord (PrioHeap k a) where+    compare = compare1+    {-# INLINE compare #-}++instance Ord k => Semigroup (PrioHeap k a) where+    (<>) = union+    {-# INLINE (<>) #-}++instance Ord k => Monoid (PrioHeap k a) where+    mempty = empty+    {-# INLINE mempty #-}++    mappend = (<>)+    {-# INLINE mappend #-}++instance Functor (PrioHeap k) where+    fmap = map+    {-# INLINE fmap #-}++instance Foldable (PrioHeap k) where+    foldMap f = foldMapWithKey (const f)+    {-# INLINE foldMap #-}++    foldr f = foldrWithKey (const f)+    {-# INLINE foldr #-}++    foldl f = foldlWithKey (const . f)+    {-# INLINE foldl #-}++    foldr' f = foldrWithKey' (const f)+    {-# INLINE foldr' #-}++    foldl' f = foldlWithKey' (const . f)+    {-# INLINE foldl' #-}++    null Empty = True+    null Heap{} = False+    {-# INLINE null #-}++    length = size+    {-# INLINE length #-}++instance Traversable (PrioHeap k) where+    traverse f = traverseWithKey (const f)+    {-# INLINE traverse #-}++#ifdef __GLASGOW_HASKELL__+instance Ord k => IsList (PrioHeap k a) where+    type Item (PrioHeap k a) = (k, a)++    fromList = fromList+    {-# INLINE fromList #-}++    toList = toList+    {-# INLINE toList #-}+#endif+++-- | /O(1)/. The empty heap.+--+-- > empty = fromList []+empty :: PrioHeap k a+empty = Empty+{-# INLINE empty #-}++-- | /O(1)/. A heap with a single element.+--+-- > singleton x = fromList [x]+singleton :: k -> a -> PrioHeap k a+singleton k x = Heap 1 k x Nil+{-# INLINE singleton #-}++-- | /O(n * log n)/. Create a heap from a list.+fromList :: Ord k => [(k, a)] -> PrioHeap k a+fromList = foldl' (\acc (key, x) -> insert key x acc) empty+{-# INLINE fromList #-}++-- | /O(1)/. Insert a new key and value into the heap.+insert :: Ord k => k -> a -> PrioHeap k a -> PrioHeap k a+insert key x Empty = singleton key x+insert kx x (Heap s ky y f)+    | kx <= ky = Heap (s + 1) kx x (ins ky y f)+    | otherwise = Heap (s + 1) ky y (ins kx x f)++-- | /O(log n)/. The union of two heaps.+union :: Ord k => PrioHeap k a -> PrioHeap k a -> PrioHeap k a+union heap Empty = heap+union Empty heap = heap+union (Heap s1 key1 x1 f1) (Heap s2 key2 x2 f2)+    | key1 <= key2 = Heap (s1 + s2) key1 x1 (ins key2 x2 (merge f1 f2))+    | otherwise = Heap (s1 + s2) key2 x2 (ins key1 x1 (merge f1 f2))++-- | The union of a foldable of heaps.+--+-- > unions = foldl union empty+unions :: (Foldable f, Ord k) => f (PrioHeap k a) -> PrioHeap k a+unions = foldl' union empty+{-# INLINE unions #-}++-- | /O(n)/. Map a function over the heap.+map :: (a -> b) -> PrioHeap k a -> PrioHeap k b+map f = mapWithKey (const f)+{-# INLINE map #-}++-- | /O(n)/. Map a function that has access to the key associated with a value over the heap.+mapWithKey :: (k -> a -> b) -> PrioHeap k a -> PrioHeap k b+mapWithKey _ Empty = Empty+mapWithKey f (Heap s key x forest) = Heap s key (f key x) (fmap mapTree forest)+  where+    mapTree (Node r key x xs c) = Node r key (f key x) (fmap mapPair xs) (fmap mapTree c)+    mapPair (Pair key x) = Pair key (f key x)+{-# INLINE mapWithKey #-}++-- | /O(n)/. Traverse the heap with a function that has access to the key associated with a value.+traverseWithKey :: Applicative f => (k -> a -> f b) -> PrioHeap k a -> f (PrioHeap k b)+traverseWithKey _ Empty = pure Empty+traverseWithKey f (Heap s key x forest) = Heap s key <$> f key x <*> traverse traverseTree forest+  where+    traverseTree (Node r key x xs c) = Node r key <$> f key x <*> traverse traversePair xs <*> traverse traverseTree c+    traversePair (Pair key x) = Pair key <$> f key x+{-# INLINE traverseWithKey #-}++-- | /O(n)/. Filter all elements that satisfy the predicate.+filter :: Ord k => (a -> Bool) -> PrioHeap k a -> PrioHeap k a+filter f = filterWithKey (const f)+{-# INLINE filter #-}++-- | /O(n)/. Filter all elements that satisfy the predicate.+filterWithKey :: Ord k => (k -> a -> Bool) -> PrioHeap k a -> PrioHeap k a+filterWithKey f = foldrWithKey f' empty+  where+    f' key x heap+        | f key x = insert key x heap+        | otherwise = heap+{-# INLINE filterWithKey #-}++-- | /O(n)/. Partition the heap into two heaps, one with all elements that satisfy the predicate+-- and one with all elements that don't satisfy the predicate.+partition :: Ord k => (a -> Bool) -> PrioHeap k a -> (PrioHeap k a, PrioHeap k a)+partition f = partitionWithKey (const f)+{-# INLINE partition #-}++-- | /O(n)/. Partition the heap into two heaps, one with all elements that satisfy the predicate+-- and one with all elements that don't satisfy the predicate.+partitionWithKey :: Ord k => (k -> a -> Bool) -> PrioHeap k a -> (PrioHeap k a, PrioHeap k a)+partitionWithKey f = foldrWithKey f' (empty, empty)+  where+    f' key x (heap1, heap2)+        | f key x = (insert key x heap1, heap2)+        | otherwise = (heap1, insert key x heap2)+{-# INLINE partitionWithKey #-}++-- | /O(n)/. Map and collect the 'Just' results.+mapMaybe :: Ord k => (a -> Maybe b) -> PrioHeap k a -> PrioHeap k b+mapMaybe f = mapMaybeWithKey (const f)+{-# INLINE mapMaybe #-}++-- | /O(n)/. Map and collect the 'Just' results.+mapMaybeWithKey :: Ord k => (k -> a -> Maybe b) -> PrioHeap k a -> PrioHeap k b+mapMaybeWithKey f = foldrWithKey f' empty+  where+    f' key x heap = case f key x of+        Just y -> insert key y heap+        Nothing -> heap+{-# INLINE mapMaybeWithKey #-}++-- | /O(n)/. Map and separate the 'Left' and 'Right' results.+mapEither :: Ord k => (a -> Either b c) -> PrioHeap k a -> (PrioHeap k b, PrioHeap k c)+mapEither f = mapEitherWithKey (const f)+{-# INLINE mapEither #-}++-- | /O(n)/. Map and separate the 'Left' and 'Right' results.+mapEitherWithKey :: Ord k => (k -> a -> Either b c) -> PrioHeap k a -> (PrioHeap k b, PrioHeap k c)+mapEitherWithKey f = foldrWithKey f' (empty, empty)+  where+    f' key x (heap1, heap2) = case f key x of+        Left y -> (insert key y heap1, heap2)+        Right y -> (heap1, insert key y heap2)+{-# INLINE mapEitherWithKey #-}++-- | /O(n)/. Fold the keys and values in the heap, using the given monoid.+foldMapWithKey :: Monoid m => (k -> a -> m) -> PrioHeap k a -> m+foldMapWithKey f = foldrWithKey (\key x acc -> f key x `mappend` acc) mempty+{-# INLINE foldMapWithKey #-}++-- | /O(n)/. Fold the keys and values in the heap, using the given right-associative function.+foldrWithKey :: (k -> a -> b -> b) -> b -> PrioHeap k a -> b+foldrWithKey _ acc Empty = acc+foldrWithKey f acc (Heap _ key x forest) = f key x (foldr foldTree acc forest)+  where+    foldTree (Node _ key x xs c) acc = f key x (foldr (uncurry f) (foldr foldTree acc c) xs)++-- | /O(n)/. Fold the keys and values in the heap, using the given left-associative function.+foldlWithKey :: (b -> k -> a -> b) -> b -> PrioHeap k a -> b+foldlWithKey _ acc Empty = acc+foldlWithKey f acc (Heap _ key x forest) = foldl foldTree (f acc key x) forest+  where+    foldTree acc (Node _ key x xs c) = foldl foldTree (foldl (uncurry . f) (f acc key x) xs) c++-- | /O(n)/. A strict version of 'foldrWithKey'.+-- Each application of the function is evaluated before using the result in the next application.+foldrWithKey' :: (k -> a -> b -> b) -> b -> PrioHeap k a -> b+foldrWithKey' f acc h = foldlWithKey f' id h acc+  where+    f' k key x z = k $! f key x z+{-# INLINE foldrWithKey' #-}++-- | /O(n)/. A strict version of 'foldlWithKey'.+-- Each application of the function is evaluated before using the result in the next application.+foldlWithKey' :: (b -> k -> a -> b) -> b -> PrioHeap k a -> b+foldlWithKey' f acc h = foldrWithKey f' id h acc+  where+    f' key x k z = k $! f z key x+{-# INLINE foldlWithKey' #-}++-- | /O(n * log n)/. Fold the values in the heap in order, using the given monoid.+foldMapOrd :: (Ord k, Monoid m) => (a -> m) -> PrioHeap k a -> m+foldMapOrd f = foldMapWithKeyOrd (const f)+{-# INLINE foldMapOrd #-}++-- | /O(n * log n)/. Fold the values in the heap in order, using the given right-associative function.+foldrOrd :: Ord k => (a -> b -> b) -> b -> PrioHeap k a -> b+foldrOrd f = foldrWithKeyOrd (const f)+{-# INLINE foldrOrd #-}++-- | /O(n * log n)/. Fold the values in the heap in order, using the given left-associative function.+foldlOrd :: Ord k => (b -> a -> b) -> b -> PrioHeap k a -> b+foldlOrd f = foldlWithKeyOrd (const . f)+{-# INLINE foldlOrd #-}++-- | /O(n * log n)/. A strict version of 'foldrOrd'.+-- Each application of the function is evaluated before using the result in the next application.+foldrOrd' :: Ord k => (a -> b -> b) -> b -> PrioHeap k a -> b+foldrOrd' f = foldrWithKeyOrd' (const f)+{-# INLINE foldrOrd' #-}++-- | /O(n)/. A strict version of 'foldlOrd'.+-- Each application of the function is evaluated before using the result in the next application.+foldlOrd' :: Ord k => (b -> a -> b) -> b -> PrioHeap k a -> b+foldlOrd' f = foldlWithKeyOrd' (const . f)+{-# INLINE foldlOrd' #-}++-- | /O(n * log n)/. Fold the keys and values in the heap in order, using the given monoid.+foldMapWithKeyOrd :: (Ord k, Monoid m) => (k -> a -> m) -> PrioHeap k a -> m+foldMapWithKeyOrd f = foldrWithKeyOrd (\key x acc -> f key x `mappend` acc) mempty+{-# INLINE foldMapWithKeyOrd #-}++-- | /O(n * log n)/. Fold the keys and values in the heap in order, using the given right-associative function.+foldrWithKeyOrd :: Ord k => (k -> a -> b -> b) -> b -> PrioHeap k a -> b+foldrWithKeyOrd f acc = go+  where+    go h = case minView h of+        Nothing -> acc+        Just ((key, x), h') -> f key x (go h')+{-# INLINE foldrWithKeyOrd #-}++-- | /O(n * log n)/. Fold the keys and values in the heap in order, using the given left-associative function.+foldlWithKeyOrd :: Ord k => (b -> k -> a -> b) -> b -> PrioHeap k a -> b+foldlWithKeyOrd f = go+  where+    go acc h = case minView h of+        Nothing -> acc+        Just ((key, x), h') -> go (f acc key x) h'+{-# INLINE foldlWithKeyOrd #-}++-- | /O(n * log n)/. A strict version of 'foldrWithKeyOrd'.+-- Each application of the function is evaluated before using the result in the next application.+foldrWithKeyOrd' :: Ord k => (k -> a -> b -> b) -> b -> PrioHeap k a -> b+foldrWithKeyOrd' f acc h = foldlWithKeyOrd f' id h acc+  where+    f' k key x z = k $! f key x z+{-# INLINE foldrWithKeyOrd' #-}++-- | /O(n)/. A strict version of 'foldlWithKeyOrd'.+-- Each application of the function is evaluated before using the result in the next application.+foldlWithKeyOrd' :: Ord k => (b -> k -> a -> b) -> b -> PrioHeap k a -> b+foldlWithKeyOrd' f acc h = foldrWithKeyOrd f' id h acc+  where+    f' key x k z = k $! f z key x+{-# INLINE foldlWithKeyOrd' #-}++-- | /O(1)/. The number of elements in the heap.+size :: PrioHeap k a -> Int+size Empty = 0+size (Heap s _ _ _) = s+{-# INLINE size #-}++-- | /O(n)/. Is the key a member of the heap?+member :: Ord k => k -> PrioHeap k a -> Bool+member _ Empty = False+member kx (Heap _ ky _ forest) = kx <= ky && any (kx `elemTree`) forest+  where+    kx `elemTree` (Node _ ky _ ys c) = kx <= ky && (any (\(Pair a _) -> kx == a) ys || any (kx `elemTree`) c)++-- | /O(n)/. Is the value not a member of the heap?+notMember :: Ord k => k -> PrioHeap k a -> Bool+notMember key = not . member key++-- | /O(1)/. Adjust the value at the minimal key.+adjustMin :: (a -> a) -> PrioHeap k a -> PrioHeap k a+adjustMin f = adjustMinWithKey (const f)+{-# INLINE adjustMin #-}++-- | /O(1)/. Adjust the value at the minimal key.+adjustMinWithKey :: (k -> a -> a) -> PrioHeap k a -> PrioHeap k a+adjustMinWithKey _ Empty = Empty+adjustMinWithKey f (Heap s key x forest) = Heap s key (f key x) forest++-- | /O(1)/. The minimal element in the heap or 'Nothing' if the heap is empty.+lookupMin :: PrioHeap k a -> Maybe (k, a)+lookupMin Empty = Nothing+lookupMin (Heap _ key x _) = Just (key, x)+{-# INLINE lookupMin #-}++-- | /O(1)/. The minimal element in the heap. Calls 'error' if the heap is empty.+findMin :: PrioHeap k a -> (k, a)+findMin heap = fromMaybe (errorEmpty "findMin") (lookupMin heap)+{-# INLINE findMin #-}++-- | /O(log n)/. Delete the minimal element. Returns the empty heap if the heap is empty.+deleteMin :: Ord k => PrioHeap k a -> PrioHeap k a+deleteMin Empty = Empty+deleteMin (Heap s _ _ f) = fromForest (s - 1) f++-- | /O(log n)/. Delete and find the minimal element. Calls 'error' if the heap is empty.+--+-- > deleteFindMin heap = (findMin heap, deleteMin heap)+deleteFindMin :: Ord k => PrioHeap k a -> ((k, a), PrioHeap k a)+deleteFindMin heap = fromMaybe (errorEmpty "deleteFindMin") (minView heap)+{-# INLINE deleteFindMin #-}++-- | /O(log n)/. Update the value at the minimal key.+updateMin :: Ord k => (a -> Maybe a) -> PrioHeap k a -> PrioHeap k a+updateMin f = updateMinWithKey (const f)+{-# INLINE updateMin #-}++-- | /O(log n)/. Update the value at the minimal key.+updateMinWithKey :: Ord k => (k -> a -> Maybe a) -> PrioHeap k a -> PrioHeap k a+updateMinWithKey _ Empty = Empty+updateMinWithKey f (Heap s key x forest) = case f key x of+    Nothing -> fromForest (s - 1) forest+    Just x' -> Heap s key x' forest++-- | /O(log n)/. Retrieves the minimal key/value pair of the heap and the heap stripped of that element or 'Nothing' if the heap is empty.+minView :: Ord k => PrioHeap k a -> Maybe ((k, a), PrioHeap k a)+minView Empty = Nothing+minView (Heap s key x f) = Just ((key, x), fromForest (s - 1) f)+{-# INLINE minView #-}++-- | /O(n * log n)/. @take n heap@ takes the @n@ smallest elements of @heap@, in ascending order.+--+-- > take n heap = take n (toAscList heap)+take :: Ord k => Int -> PrioHeap k a -> [(k, a)]+take n h+    | n <= 0 = []+    | otherwise = case minView h of+        Nothing -> []+        Just (x, h') -> x : take (n - 1) h'++-- | /O(n * log n)/. @drop n heap@ drops the @n@ smallest elements from @heap@.+drop :: Ord k => Int -> PrioHeap k a -> PrioHeap k a+drop n h+    | n <= 0 = h+    | otherwise = drop (n - 1) (deleteMin h)++-- | /O(n * log n)/. @splitAt n heap@ takes and drops the @n@ smallest elements from @heap@.+splitAt :: Ord k => Int -> PrioHeap k a -> ([(k, a)], PrioHeap k a)+splitAt n h+    | n <= 0 = ([], h)+    | otherwise = case minView h of+        Nothing -> ([], h)+        Just (x, h') -> let (xs, h'') = splitAt (n - 1) h' in (x : xs, h'')++-- | /O(n * log n)/. @takeWhile p heap@ takes the elements from @heap@ in ascending order, while @p@ holds.+takeWhile :: Ord k => (a -> Bool) -> PrioHeap k a -> [(k, a)]+takeWhile p = takeWhileWithKey (const p)+{-# INLINE takeWhile #-}++-- | /O(n * log n)/. @takeWhileWithKey p heap@ takes the elements from @heap@ in ascending order, while @p@ holds.+takeWhileWithKey :: Ord k => (k -> a -> Bool) -> PrioHeap k a -> [(k, a)]+takeWhileWithKey p = go+  where+    go h = case minView h of+        Nothing -> []+        Just ((key, x), h') -> if p key x then (key, x) : go h' else []+{-# INLINE takeWhileWithKey #-}++-- | /O(n * log n)/. @dropWhile p heap@ drops the elements from @heap@ in ascending order, while @p@ holds.+dropWhile :: Ord k => (a -> Bool) -> PrioHeap k a -> PrioHeap k a+dropWhile p = dropWhileWithKey (const p)+{-# INLINE dropWhile #-}++-- | /O(n * log n)/. @dropWhileWithKey p heap@ drops the elements from @heap@ in ascending order, while @p@ holds.+dropWhileWithKey :: Ord k => (k -> a -> Bool) -> PrioHeap k a -> PrioHeap k a+dropWhileWithKey p = go+  where+    go h = case minView h of+        Nothing -> h+        Just ((key, x), h') -> if p key x then go h' else h+{-# INLINE dropWhileWithKey #-}++-- | /O(n * log n)/. @span p heap@ takes and drops the elements from @heap@, while @p@ holds+span :: Ord k => (a -> Bool) -> PrioHeap k a -> ([(k, a)], PrioHeap k a)+span p = spanWithKey (const p)+{-# INLINE span #-}++-- | /O(n * log n)/. @spanWithKey p heap@ takes and drops the elements from @heap@, while @p@ holds+spanWithKey :: Ord k => (k -> a -> Bool) -> PrioHeap k a -> ([(k, a)], PrioHeap k a)+spanWithKey p = go+  where+    go h = case minView h of+        Nothing -> ([], h)+        Just ((key, x), h') -> if p key x+            then let (xs, h'') = go h' in ((key, x) : xs, h'')+            else ([], h)+{-# INLINE spanWithKey #-}++-- | /O(n * log n)/. @span@, but with inverted predicate.+break :: Ord k => (a -> Bool) -> PrioHeap k a -> ([(k, a)], PrioHeap k a)+break p = span (not . p)+{-# INLINE break #-}++-- | /O(n * log n)/. @spanWithKey@, but with inverted predicate.+breakWithKey :: Ord k => (k -> a -> Bool) -> PrioHeap k a -> ([(k, a)], PrioHeap k a)+breakWithKey p = spanWithKey (\key x -> not (p key x))+{-# INLINE breakWithKey #-}++-- | /O(n * log n)/. Remove duplicate elements from the heap.+nub :: Ord k => PrioHeap k a -> PrioHeap k a+nub h = case minView h of+    Nothing -> Empty+    Just ((key, x), h') -> insert key x (nub (dropWhileWithKey (const . (== key)) h'))++-- | /O(n)/. Create a list of key/value pairs from the heap.+toList :: PrioHeap k a -> [(k, a)]+toList = foldrWithKey (\key x acc -> (key, x) : acc) []++-- | /O(n * log n)/. Create an ascending list of key/value pairs from the heap.+toAscList :: Ord k => PrioHeap k a -> [(k, a)]+toAscList = foldrWithKeyOrd (\key x acc -> (key, x) : acc) []++-- | /O(n * log n)/. Create a descending list of key/value pairs from the heap.+toDescList :: Ord k => PrioHeap k a -> [(k, a)]+toDescList = foldlWithKeyOrd (\acc key x -> (key, x) : acc) []++-- | /O(n)/. Create a heap from a 'Data.Heap.Heap' of keys and a function which computes the value for each key.+fromHeap :: (k -> a) -> Heap.Heap k -> PrioHeap k a+fromHeap _ Heap.Empty = Empty+fromHeap f (Heap.Heap s key forest) = Heap s key (f key) (fmap fromTree forest)+  where+    fromTree (Heap.Node r key xs c) = Node r key (f key) (fmap (\key -> Pair key (f key)) xs) (fmap fromTree c)++-- | Create a 'Data.Heap.Heap' of all keys of the heap+keysHeap :: PrioHeap k a -> Heap.Heap k+keysHeap Empty = Heap.Empty+keysHeap (Heap s key _ forest) = Heap.Heap s key (fmap fromTree forest)+  where+    fromTree (Node r key _ xs c) = Heap.Node r key (fmap (\(Pair key _) -> key) xs) (fmap fromTree c)
+ src/Util/Internal/StrictList.hs view
@@ -0,0 +1,39 @@+module Util.Internal.StrictList+    ( List(..)+    , reverse+    ) where++import Prelude hiding (reverse)++-- | A strict list.+data List a = Nil | !a `Cons` !(List a)++infixr 5 `Cons`++instance Functor List where+    fmap f = go+      where+        go Nil = Nil+        go (x `Cons` xs) = f x `Cons` go xs+    {-# INLINE fmap #-}++instance Foldable List where+    foldr f acc = go+      where+        go Nil = acc+        go (x `Cons` xs) = f x (go xs)+    {-# INLINE foldr #-}++instance Traversable List where+    traverse f = go+      where+        go Nil = pure Nil+        go (x `Cons` xs) = Cons <$> f x <*> go xs+    {-# INLINE traverse #-}++reverse :: List a -> List a+reverse = rev Nil+  where+    rev acc Nil = acc+    rev acc (t `Cons` ts) = rev (t `Cons` acc) ts+{-# INLINE reverse #-}
+ test/Spec.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE ScopedTypeVariables #-}++import Data.Bifunctor (bimap)+import Data.Foldable (toList)+import Data.List (partition, sort)++import Test.Hspec+import Test.QuickCheck++import Data.AMT (Vector)+import qualified Data.AMT as V+import Data.Heap (Heap)+import qualified Data.Heap as H+import Data.PrioHeap (PrioHeap)+import qualified Data.PrioHeap as P++instance Arbitrary a => Arbitrary (Vector a) where+    arbitrary = fmap V.fromList arbitrary++instance (Arbitrary a, Ord a) => Arbitrary (Heap a) where+    arbitrary = fmap H.fromList arbitrary++instance (Arbitrary k, Arbitrary a, Ord k) => Arbitrary (PrioHeap k a) where+    arbitrary = fmap P.fromList arbitrary++uncons :: [a] -> Maybe (a, [a])+uncons [] = Nothing+uncons (x : xs) = Just (x, xs)++unsnoc :: [a] -> Maybe ([a], a)+unsnoc [] = Nothing+unsnoc xs@(_ : _) = Just (init xs, last xs)++main :: IO ()+main = hspec $ do+    describe "Data.AMT" $ do+        it "satisfies `fromList . toList == id`" $+            property $ \(v :: Vector Int) -> V.fromList (toList v) === v+        it "satisfies `toList . fromList == id`" $+            property $ \(ls :: [Int]) -> toList (V.fromList ls) === ls+        describe "length" $ do+            it "returns the length" $+                property $ \(v :: Vector Int) -> length v === length (toList v)+            it "returns 0 for the empty vector" $+                length V.empty `shouldBe` 0+        describe "snoc" $ do+            it "appends an element to the back" $+                property $ \(v :: Vector Int) x -> toList (v V.|> x) === toList v ++ [x]+            it "works for the empty vector" $+                property $ \(x :: Int) -> V.empty V.|> x `shouldBe` V.singleton x+        describe "unsnoc" $ do+            it "analyzes the back of the vector" $+                property $ \(v :: Vector Int) -> V.viewr v === fmap (\(xs, x) -> (V.fromList xs, x)) (unsnoc (toList v))+            it "returns Nothing for the empty vector" $+                V.viewr V.empty `shouldBe` (Nothing :: Maybe (Vector Int, Int))+        describe "take" $+            it "takes the first n elements" $+                property $ \n (xs :: [Int]) -> V.take n (V.fromList xs) === V.fromList (take n xs)++    describe "Data.Heap" $ do+        it "satisfies `fromList . toList == id`" $+            property $ \(h :: Heap Int) -> H.fromList (toList h) === h+        describe "size" $ do+            it "returns the size" $+                property $ \(h :: Heap Int) -> H.size h === length (toList h)+            it "returns 0 for the empty heap" $+                H.size H.empty `shouldBe` 0+        describe "union" $+            it "returns the union of two heaps" $+                property $ \(xs :: [Int]) (ys :: [Int]) -> H.fromList xs `H.union` H.fromList ys === H.fromList (xs ++ ys)+        describe "insert" $+            it "inserts an element" $+                property $ \(xs :: [Int]) (x :: Int) -> H.insert x (H.fromList xs) === H.fromList (x : xs)+        describe "deleteMin" $+            it "deletes the minimum element" $+                property $ \(xs :: [Int]) -> H.deleteMin (H.fromList xs) === maybe H.empty (H.fromList . snd) (uncons (sort xs))+        describe "filter" $+            it "filters the elements that satisfy the predicate" $+                property $ \(xs :: [Int]) -> H.filter even (H.fromList xs) === H.fromList (filter even xs)+        describe "partition" $+            it "partitions the elements based on the predicate" $+                property $ \(xs :: [Int]) -> H.partition even (H.fromList xs) === bimap H.fromList H.fromList (partition even xs)+        describe "heapsort" $+            it "sorts a list" $+                property $ \(ls :: [Int]) -> H.heapsort ls === sort ls++    describe "Data.PrioHeap" $ do+        it "satisfies `fromList . toList == id`" $+            property $ \(h :: PrioHeap Int ()) -> P.fromList (P.toList h) === h+        describe "size" $ do+            it "returns the size" $+                property $ \(h :: PrioHeap Int Int) -> P.size h === length (toList h)+            it "returns 0 for the empty heap" $+                P.size P.empty `shouldBe` 0+        describe "union" $+            it "returns the union of two heaps" $+                property $ \(xs :: [(Int, ())]) (ys :: [(Int, ())]) -> P.fromList xs `P.union` P.fromList ys === P.fromList (xs ++ ys)+        describe "insert" $+            it "inserts an element" $+                property $ \(xs :: [(Int, ())]) (x :: Int) -> P.insert x () (P.fromList xs) === P.fromList ((x, ()) : xs)+        describe "deleteMin" $+            it "deletes the minimum element" $+                property $ \(xs :: [(Int, ())]) -> P.deleteMin (P.fromList xs) === maybe P.empty (P.fromList . snd) (uncons (sort xs))+        describe "filterWithKey" $+            it "filters the elements that satisfy the predicate" $+                property $ \(xs :: [(Int, ())]) -> P.filterWithKey (const . even) (P.fromList xs) === P.fromList (filter (even . fst) xs)+        describe "partitionWithKey" $+            it "partitions the elements based on the predicate" $+                property $ \(xs :: [(Int, ())]) -> P.partitionWithKey (const . even) (P.fromList xs) === bimap P.fromList P.fromList (partition (even . fst) xs)