packages feed

stable-heap (empty) → 0.1.0.0

raw patch · 5 files changed

+319/−0 lines, 5 filesdep +basedep +criteriondep +fingertreesetup-changed

Dependencies added: base, criterion, fingertree, heaps, mwc-random, pqueue, stable-heap, vector

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Jake McArthur++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Bench.hs view
@@ -0,0 +1,33 @@+import Criterion.Main++import Data.List (unfoldr)+import Data.Vector.Unboxed (Vector)+import qualified Data.Vector.Unboxed as Vector+import System.Random.MWC+import qualified Data.Foldable as Foldable+import Control.Arrow++import qualified Data.Heap.Stable as Stable+import qualified Data.PQueue.Prio.Min as PQueue+import qualified Data.PriorityQueue.FingerTree as FingerTree+import qualified Data.Heap as Heap++createGroup :: Vector (Int, ()) -> String -> (a -> [(Int, ())]) -> (a -> Int -> () -> a) -> a -> Benchmark+createGroup xs name toListAsc snoc empty =+  bench name $ whnf (sum . map fst . toListAsc . Vector.foldl' (\acc (k, v) -> snoc acc k v) empty) xs++main :: IO ()+main = do+  gen <- create+  xs <- asGenIO (`uniformVector` 1000) gen :: IO (Vector Int)+  let create = createGroup (Vector.zip xs (Vector.replicate 1000 ()))+  defaultMain+    [ bgroup "unstable"+      [ create "pqueue" PQueue.toAscList (\q k v -> PQueue.insert k v q) PQueue.empty+      , create "heap" (map (Heap.priority &&& Heap.payload) . Foldable.toList) (\h k v -> Heap.insert (Heap.Entry k v) h) Heap.empty+      ]+    , bgroup "stable"+      [ create "stable-heap" Stable.toListAsc Stable.snoc Stable.empty+      , create "fingertree" (unfoldr FingerTree.minViewWithKey) (\q k v -> FingerTree.add k v q) FingerTree.empty+      ]+    ]
+ src/Data/Heap/Stable.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Trustworthy #-}++-- |+-- Module      :  Data.Heap.Stable+-- Copyright   :  (C) Jake McArthur 2015+-- License     :  MIT+-- Maintainer  :  Jake.McArthur@gmail.com+-- Stability   :  experimental+--+-- This module provides an implementation of stable heaps, or fair+-- priority queues. The data structure is a fairly simple tweak to add+-- stability to the lazy pairing heaps described in+-- /Purely Functional Data Structures/, by Chris Okasaki.+--+-- Unless stated otherwise, the documented asymptotic efficiencies of+-- functions on 'Heap' assume that arguments are already in WHNF and+-- that the result is to be evaluated to WHNF.+module Data.Heap.Stable+       ( Heap ()+       , empty+       , singleton+       , union+       , minViewWithKey+       , cons+       , snoc+       , foldrWithKey+       , toList+       , toListAsc+       , fromList+       , bimap+       , mapKeys+       ) where++import qualified Control.Applicative as Applicative+import Control.Monad+import Data.List (foldl', unfoldr)+import Data.Monoid++import qualified GHC.Exts++-- | Semantically, @Heap k a@ is equivalent to @[(k, a)]@, but its+-- operations have different efficiencies.+data Heap k a+  = Heap !(Heap k a) (Heap k a) !k a (Heap k a) !(Heap k a)+  | Empty+  deriving (Functor, Foldable, Traversable)++-- | @toList empty = []@+empty :: Heap k a+empty = Empty++-- | /O(1)/.+--+-- > toList (singleton k v) = [(k, v)]+singleton :: k -> a -> Heap k a+singleton k v = Heap empty empty k v empty empty++-- | /O(1)/.+--+-- > toList (xs `union` ys) = toList xs ++ toList ys+union :: Ord k => Heap k a -> Heap k a -> Heap k a+Empty `union` ys = ys+xs `union` Empty = xs+xs@(Heap l1 ls1 k1 v1 rs1 r1) `union` ys@(Heap l2 ls2 k2 v2 rs2 r2)+  | k1 <= k2 =+      case r1 of+        Empty            -> Heap l1 ls1 k1 v1  rs1                     ys+        Heap _ _ _ _ _ _ -> Heap l1 ls1 k1 v1 (rs1 `union` (r1 `union` ys)) Empty+  | otherwise =+      case l2 of+        Empty            -> Heap         xs                     ls2  k2 v2 rs2 r2+        Heap _ _ _ _ _ _ -> Heap Empty ((xs `union` l2) `union` ls2) k2 v2 rs2 r2++-- | Split the 'Heap' at the leftmost occurrence of the smallest key+-- contained in the 'Heap'.+--+-- When the 'Heap' is empty, /O(1)/. When the 'Heap' is not empty,+-- finding the key and value is /O(1)/, and evaluating the remainder+-- of the heap to the left or right of the key-value pair is amortized+-- /O(log n)/.+--+-- > toList xs =+-- > case minViewWithKey xs of+-- >   Nothing -> []+-- >   Just (l, kv, r) -> toList l ++ [kv] ++ toList r+minViewWithKey :: Ord k => Heap k a -> Maybe (Heap k a, (k, a), Heap k a)+minViewWithKey Empty = Nothing+minViewWithKey (Heap l ls k v rs r) = Just (l `union` ls, (k, v), rs `union` r)++-- |+-- > mempty  = empty+-- > mappend = union+instance Ord k => Monoid (Heap k a) where+  mempty = empty+  mappend = union++-- | /O(1)/.+--+-- > toList (cons k v xs) = (k, v) : toList xs+cons :: Ord k => k -> a -> Heap k a -> Heap k a+cons k v = (singleton k v <>)++-- | /O(1)/.+--+-- > toList (snoc xs k v) = toList xs ++ [(k, v)]+snoc :: Ord k => Heap k a -> k -> a -> Heap k a+snoc xs k v = xs <> singleton k v++-- | > foldrWithKey f z xs = foldr (uncurry f) z (toList xs)+foldrWithKey :: (k -> a -> b -> b) -> b -> Heap k a -> b+foldrWithKey f = flip go+  where+    go Empty z = z+    go (Heap l ls k v rs r) z = go l (go ls (f k v (go rs (go r z))))++-- | List the key-value pairs in a 'Heap' in occurrence order. This is the semantic+-- function for 'Heap'.+--+-- /O(n)/ when the spine of the result is evaluated fully.+toList :: Heap k a -> [(k, a)]+toList = foldrWithKey (\k v xs -> (k, v) : xs) []++-- | List the key-value pairs in a 'Heap' in key order.+--+-- /O(n log n)/ when the spine of the result is evaluated fully.+toListAsc :: Ord k => Heap k a -> [(k, a)]+toListAsc = unfoldr f+  where+    f xs =+      case minViewWithKey xs of+        Nothing -> Nothing+        Just (l, kv, r) -> Just (kv, l <> r)++-- | Construct a 'Heap' from a list of key-value pairs.+--+-- /O(n)/.+fromList :: Ord k => [(k, a)] -> Heap k a+fromList = foldl' (\acc (k, v) -> snoc acc k v) empty++-- | > toList (bimap f g xs) = map (f *** g) (toList xs)+bimap :: Ord k2 => (k1 -> k2) -> (a -> b) -> Heap k1 a -> Heap k2 b+bimap f g = go+  where+    go Empty = Empty+    go (Heap l ls k v rs r) = go l <> go ls <> singleton (f k) (g v) <> go rs <> go r++-- | > toList (mapKeys f xs) = map (first f) (toList xs)+mapKeys :: Ord k2 => (k1 -> k2) -> Heap k1 a -> Heap k2 a+mapKeys f = bimap f id++-- | Same semantics as @WriterT k []@+instance (Monoid k, Ord k) => Applicative (Heap k) where+  pure = singleton mempty+  Empty <*> _ = Empty+  _ <*> Empty = Empty+  (Heap fl fls fk f frs fr) <*> xs+    =  (fl  <*>         xs)+    <> (fls <*>         xs)+    <> (bimap (fk <>) f xs)+    <> (frs <*>         xs)+    <> (fr  <*>         xs)++-- | Same semantics as @WriterT k []@+instance (Monoid k, Ord k) => Monad (Heap k) where+  return = pure+  Empty >>= _ = Empty+  Heap xl xls xk x xrs xr >>= f+    =  (xl  >>= f)+    <> (xls >>= f)+    <> (mapKeys (xk <>) (f x))+    <> (xrs >>= f)+    <> (xr  >>= f)++instance (Show k, Show a) => Show (Heap k a) where+  showsPrec d h = showParen (d > 10) $ showString "fromList " . shows (toList h)++instance (Ord k, Read k, Read a) => Read (Heap k a) where+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList", s) <- lex r+    (xs, t) <- reads s+    return (fromList xs, t)++instance Ord k => GHC.Exts.IsList (Heap k a) where+  type Item (Heap k a) = (k, a)+  fromList = fromList+  toList   = toList++-- | > xs == ys = toList xs == toList ys+instance (Eq k, Eq a) => Eq (Heap k a) where+  xs == ys = toList xs == toList ys++-- | > compare xs ys = compare (toList xs) (toList ys)+instance (Ord k, Ord a) => Ord (Heap k a) where+  compare xs ys = compare (toList xs) (toList ys)++-- |+-- > empty = empty+-- > (<|>) = union+instance (Monoid k, Ord k) => Applicative.Alternative (Heap k) where+  empty = mempty+  (<|>) = mappend++-- |+-- > mzero = empty+-- > mplus = union+instance (Monoid k, Ord k) => MonadPlus (Heap k) where+  mzero = mempty+  mplus = mappend
+ stable-heap.cabal view
@@ -0,0 +1,54 @@+name:                stable-heap+version:             0.1.0.0+synopsis:            Purely functional stable heaps (fair priority queues)+description:+        This library provides a purely functional implementation of+        stable heaps (fair priority queues). The data structure is a+        cousin of the pairing heap which maintains a sequential+        ordering of the keys. Insertion can be to either end of the+        heap, as though it is a deque, and it can be split on the+        left-most occurrence of the minimum key.+        .+        The current state of the package is fairly barebones. It will+        be fleshed out later.+license:             MIT+license-file:        LICENSE+author:              Jake McArthur+maintainer:          Jake.McArthur@gmail.com+copyright:           Copyright (C) 2015 Jake McArthur+homepage:            http://hub.darcs.net/jmcarthur/stable-heap+bug-reports:         http://hub.darcs.net/jmcarthur/stable-heap/issues+category:            Data Structures+build-type:          Simple+cabal-version:       >=1.10+stability:           experimental++library+  exposed-modules:     Data.Heap.Stable+  build-depends:       base >=4.8 && <4.9+  hs-source-dirs:      src+  default-language:    Haskell2010+  other-extensions:    DeriveTraversable, Trustworthy, TypeFamilies++benchmark bench+  type:                exitcode-stdio-1.0+  hs-source-dirs:      bench+  build-depends:       base >=4.8 && <4.9,+                       criterion >= 1.1,+                       fingertree >= 0.1,+                       heaps >= 0.3,+                       mwc-random >= 0.13,+                       pqueue >= 1.2,+                       stable-heap,+                       vector >= 0.10+  main-is:             Bench.hs+  default-language:    Haskell2010++source-repository head+  type:     darcs+  location: http://hub.darcs.net/jmcarthur/stable-heap++source-repository this+  type:     darcs+  location: http://hub.darcs.net/jmcarthur/stable-heap+  tag:      v0.1.0.0